perm filename COMPLR[MAC,LSP]1 blob
sn#396976 filedate 1978-12-10 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00103 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00004 00002
C00007 00003
C00011 00004
C00014 00005
C00018 00006
C00020 00007
C00021 00008
C00030 00009
C00037 00010
C00049 00011
C00053 00012
C00084 00013
C00091 00014
C00104 00015
C00108 00016
C00125 00017
C00131 00018
C00137 00019
C00141 00020
C00150 00021
C00162 00022
C00167 00023
C00170 00024
C00174 00025
C00177 00026
C00181 00027
C00191 00028
C00193 00029
C00198 00030
C00202 00031
C00206 00032
C00210 00033
C00213 00034
C00222 00035
C00226 00036
C00230 00037
C00235 00038
C00238 00039
C00241 00040
C00245 00041
C00248 00042
C00252 00043
C00254 00044
C00259 00045
C00262 00046
C00266 00047
C00271 00048
C00275 00049
C00283 00050
C00287 00051
C00292 00052
C00295 00053
C00299 00054
C00304 00055
C00308 00056
C00311 00057
C00314 00058
C00322 00059
C00326 00060
C00360 00061
C00365 00062
C00379 00063
C00383 00064
C00385 00065
C00390 00066
C00394 00067
C00397 00068
C00401 00069
C00407 00070
C00411 00071
C00415 00072
C00426 00073
C00432 00074
C00439 00075
C00443 00076
C00447 00077
C00450 00078
C00453 00079
C00456 00080
C00460 00081
C00465 00082
C00467 00083
C00469 00084
C00473 00085
C00488 00086
C00490 00087
C00493 00088
C00505 00089
C00508 00090
C00511 00091
C00517 00092
C00520 00093 (TERPRI))
C00523 00094
C00528 00095
C00532 00096
C00534 00097
C00539 00098
C00544 00099
C00548 00100
C00552 00101
C00555 00102
C00556 00103 ββββ
C00557 ENDMK
C⊗;
;;; -*-LISP-*-
;;; **************************************************************
;;; ***** MACLISP ***** LISP COMPILER (COMPLR) *******************
;;; **************************************************************
;;; ** (C) Copyright 1978 Massachusetts Institute of Technology **
;;; ****** This is a Read-Only file! (All writes reserved) *******
;;; **************************************************************
;;; Following code must come before the COMPDECLARE so that only the
;;; important symbols get on the copy of the initial OBARRAY.
(COND (*PURE ;PURE-COPY the buckets of the initial
((LAMBDA (N) ; OBARRAY copy, if this loading is
(ARRAY IOBARRAY OBARRAY '()) ; requesting pure constants
(DO I 0 (1+ I) (= I N)
(STORE (IOBARRAY I) (PURCOPY (OBARRAY I)))))
(- (CADR (ARRAYDIMS 'OBARRAY)) 129.)))
((ARRAY IOBARRAY OBARRAY))) ;In the other cases, copy current OBARRAY
(DECLARE (EVAL (READ))) ;No need for #
;macro in final
(SETSYNTAX '/#
'MACRO
'(LAMBDA () (COND ((= (TYIPEEK) 35.)
(TYI) ;Flush second #
(EVAL (READ)))
('T ((LAMBDA (DATA EXLDL)
(AND (SETQ EXLDL (GET (CAR DATA) 'MACRO))
(SETQ DATA (FUNCALL EXLDL DATA)))
DATA)
(READ) () )))))
(SETQ COMPLRVERNO '##(COND ((CADDR (TRUENAME INFILE)))
('/851)))
(COMMENT DECLARATIONS FOR COMPLR ITSELF)
(DEFUN COMPDECLARE MACRO (L)
(SPECIAL
ACSMODE ARGLOC ARGNO ARITHP ARRAYOPEN ASSEMBLE ATPL ATPL1 BVARS
CAAGL CARCDR CFVFL CH CHOMPHOOK CL CLEANUPSPL CLOSED CLPROGN
CMSGFILES CNT COMPILATION-FLAGCONVERSION-TABLE COBARRAY COMAL
COMP COMPILER-STATE COMPLRVERNO CONDP CONDPNOB CONDTYPE CONDUNSF
CREADTABLE CTAG DATA DEV DISOWNED EFFS EOC-EVAL ERRFL SAVED-ERRLIST
EXIT EXITN EXLDL EXPR-HASH FASL FASLPUSH FILESCLOSEP
FIXSW FLOSW FLPDL FXPDL GAG-ERRBREAKS GENPREFIX GFYC GL GOBRKL
GOFOO GONE2 HLAC IMOSAR INFILE INITIALIZE INMLS INSTACK KTYPE
L-END-CNT LAP-INSIGNIF LAPLL LDLST LERSTP+1 LINE LINEL LMBP LOCVARS
LOUT LOUT1 LPRSL LPASST-P+1 LPASST-FXP MACROLIST MACROS MAKUNBOUND
MAPEX MAPSB MCX-TRACE MODELIST MSDEV MSDIR MUZZLED NLNVS NLNVTHTBP
NOLAP NULFU NUMACS OLVRL ONMLS OPVRL OUTFILES P1CCX P1CSQ P1GFY
P1LL P1LLCEK P1LSQ P1PCX P1PSQ P1SPECIALIZEDVS P2P PKTYP PNOB
PROGN PROGP PROGTYPE PROGUNSF PRSSL PVR PVRL QSM READ RECOMPL
REGACS REGPDL RNL ROSENCEK SFLG SLOTX SOBARRAY SPECIAL SPECIALS
SPECVARS SPLDLST SQUID SREADTABLE STATE STSL SWITCHLIST SWITCHTABLE
SYMBOLS TAKENAC1 TOPFN ITSP SAILP TTYNOTES TYO UNDFUNS UNFASLCOMMENTS
UNSFLST UREAD USR UWRITE VGO VGOL VL YESWARNTTY
)
(*FEXPR
*EXPR *FEXPR *LEXPR ARRAY* CGOL EREAD EVAL-WHEN FIXNUM FLONUM
INITIALIZE MAKLAP NOTYPE SPECIAL UNSPECIAL
)
(FIXNUM
AC ARGNO BASE BESTCNT BESTLOC CNT HLAC IBASE I II
LINEL M N NARGS NLARG NOACS P1CNT RSTNO TAKENAC1 VALAC
)
(FIXNUM
(COM-AREF) (CC0) (CLLOC) (COML1) (COMLC) (COMARRAY)
(CONVNUMLOC FIXNUM) (FRAC) (FRAC1) (FRAC5) (FRACB)
(FREENUMAC0) (FREENUMAC1) (FREENUMAC) (FREEREGAC)
(LOADINREGAC) (LOADINSOMENUMAC) (LOADINNUMAC NOTYPE FIXNUM)
(OUTFUNCALL) (P1TRESS) (ZTYI)
)
(*EXPR CARCDR CC0 CLEANUPSPL COMP COMPLRVERNO MCX-TRACE NARGS
P1GFY P1SPECIALIZEDVS SPECIALS UNSAFEP
)
(*LEXPR PNAMECONC CDUMP)
(APPLY 'ARRAY* (SUBST () () '((NOTYPE (BOLA 9 7) (STGET 10.) (CBA 16.)
(PVIA 3 17.) (A1S1A ? 4)
(AC-ADDRS 11.) (PDL-ADDRS 3 193.)))))
(FIXSW 'T) (CLOSED () ) (GENPREFIX /|N) (GENSYM 0)
'(COMMENT COMPDECLARE))
(DECLARE (ALLOC '(LIST (55296. 65536. 0.2) FIXNUM (4096. 6144. 0.2)))
(COMPDECLARE))
(COMMENT MACRO DEFUNITIONS AND INLINEABLE EXPRS)
;;; Redefine DISPLACE into something harmless if making up a *PURE
;;; version of the compiler in EXPR code
##(COND ((OR (MEMQ COMPILER-STATE '(MAKLAP DECLARE)) (NULL *PURE))
'(DEFUN CDISPLACE MACRO (X) (CONS 'DISPLACE (CDR X))))
('(DEFUN CDISPLACE (X Y) Y)))
(DEFUN OUTFS MACRO (X)
(CDISPLACE X (CONS (COND ((NULL (CDDDDR X)) 'OUT3FIELDS)
((NULL (CDR (CDDDDR X))) 'OUT4FIELDS)
('T 'OUT5FIELDS))
(REVERSE (CDR X)))))
;;; DEFUN-ILE is a macro which expands into (DEFUN <FN> MACRO ...).
;;; It allows macro definitions to be written in a natural way, using
;;; dummy parameters and a template. Eventually, it will mean
;;; "Inline-able Expr"
(DEFUN DEFUN-ILE MACRO (X)
((LAMBDA (ARGNAME MATCHOVER)
(SUBLIS (LIST (CONS 'name (CADR X))
(CONS 'arg ARGNAME)
(CONS 'subsl (FUNCALL MATCHOVER
(CADDR X)
(LIST 'CDR ARGNAME)))
(CONS 'body (COND ((CDDDDR X)
(CONS 'PROGN (CDDDR X)))
((CADDDR X)))))
(COND ((NULL (CADDR X))
'(DEFUN name MACRO (arg)
(CDISPLACE arg 'body)))
('(DEFUN name MACRO (arg)
(CDISPLACE arg (SUBLIS (LIST . subsl) 'body)))))))
(GENSYM)
'(LAMBDA (PAT VL)
(COND ((ATOM PAT)
(COND ((NULL PAT) () )
((SYMBOLP PAT) (LIST 'CONS (LIST 'QUOTE PAT) VL))
((ERROR PAT '|NON-BINDABLE ATOM -- DEFUN-ILE|))))
('T (CONS (FUNCALL MATCHOVER (CAR PAT) (LIST 'CAR VL))
(FUNCALL MATCHOVER (CDR PAT) (LIST 'CDR VL)))))) ))
(DEFUN-ILE NCDR (l n) (NTHCDR n l))
(DEFUN-ILE EQUIV (a1 a2) (COND (a1 a2) ((NULL a2))))
(DEFUN-ILE /2↑N-P (n) (ZEROP (BOOLE 4 n (- n))))
(DEFUN-ILE INVERSE-ASCII (char) (GETCHARN char 1))
(DEFUN-ILE |Oh, FOO!| () (OUTPUT 'FOO))
(DEFUN-ILE CLEARALLACS () (CLEARACS0 'T))
(DEFUN-ILE NO-DELAYED-SPLDS () (CSLD (SETQ CCSLD 'T) 'T ()))
(DEFUN-ILE ERL-SET ()
(OR (MEMBER '(COMPLRVERNO) (SETQ ERRLIST SAVED-ERRLIST))
(PUSH '(COMPLRVERNO) ERRLIST)))
(DEFUN-ILE BARF (item msg a1 a2) (MSOUT item 'msg 'BARF a1 a2))
(DEFUN-ILE DBARF (item msg a1 a2) (MSOUT item 'msg 'DATA a1 a2))
(DEFUN-ILE WARN (item msg a1 a2) (MSOUT item 'msg 'WARN a1 a2))
(DEFUN-ILE PDERR (item msg) (MSOUT item 'msg 'ERRFL 4 6))
(DEFUN-ILE KNOW-ALL-TYPES (a1)
(COND ((NULL a1) () )
((MEMQ a1 '(FIXNUM FLONUM)))
((NOT (MEMQ '() a1)))))
(DEFUN-ILE INITIALSLOTS ()
'((() () () () () ) ;REGACS
(() () () ) ;NUMACS
(() () () ) ;ACSMODE
() ;REGPDL
() ;FXPDL
() ;FLPDL
))
(DEFUN-ILE SETUP-CATCH-PDL-COUNTS ()
(SETQ LERSTP+1 13. LPASST-P+1 6. LPASST-FXP 11.))
(DEFUN-ILE NACS () '5)
(DEFUN-ILE NUMVALAC () '7)
(DEFUN-ILE NUMNACS () '3)
(DEFUN-ILE NACS+1 () '##(1+ (NACS)))
(DEFUN-ILE MAX-NPUSH () '16.)
(DEFUN-ILE MAX-0PUSH () '8)
(DEFUN-ILE MAX-0*0PUSH () '8)
(DEFUN-ILE FXP0 () '-2048.) ;2↑11. Bit implies REGPDL
(DEFUN-ILE FLP0 () '-4096.) ;2↑12. Bit (with 2↑11. off) implies FXPDL
(DEFUN-ILE NPDL-ADDRS () '192.)
(DEFUN-ILE REGADP-N (n) (LESSP ##(FXP0) n ##(NUMVALAC)))
(DEFUN-ILE REGACP (x) (AND (SIGNP G x) (< x ##(NUMVALAC)))) ;Watch OUT! Arg is copied!
(DEFUN-ILE REGACP-N (n) (LESSP 0 n ##(NUMVALAC)))
(DEFUN-ILE REGPDLP-N (n) (LESSP ##(FXP0) n 1))
(DEFUN-ILE REGPDLP (x) (AND (SIGNP LE x) (> x ##(FXP0)))) ;Watch OUT! Arg is copied!
(DEFUN-ILE PDLLOCP (x) (SIGNP LE x))
(DEFUN-ILE PDLLOCP-N (n) (NOT (> n 0)))
(DEFUN-ILE ACLOCP (x) (SIGNP G x))
(DEFUN-ILE ACLOCP-N (n) (> n 0))
(DEFUN-ILE NUMACP (x) (AND (SIGNP G x) (NOT (< x ##(NUMVALAC))))) ;Watch OUT! Arg is copied!
(DEFUN-ILE NUMACP-N (n) (NOT (< n ##(NUMVALAC))))
(DEFUN-ILE NUMPDLP (x) (AND (SIGNP LE x) (NOT (> x ##(FXP0))))) ;Watch OUT! Arg is copied!
(DEFUN-ILE NUMPDLP-N (n) (NOT (> n ##(FXP0))))
(DEFUN-ILE FLPDLP-N (n) (NOT (> n ##(FLP0))))
(DEFUN-ILE PDLAC (mode)
(COND ((EQ mode 'FIXNUM) 'FXP)
((NULL mode) 'P)
('FLP)))
(DEFUN-ILE PDLGET (mode)
(COND ((EQ mode 'FIXNUM) FXPDL)
((NULL mode) REGPDL)
(FLPDL)))
(DEFUN-ILE ACSGET (mode) (COND (mode NUMACS) (REGACS)))
(DEFUN-ILE ACSSLOT (n)
(COND ((= n ##(NUMVALAC)) NUMACS)
((= n ##(1+ (NUMVALAC))) (CDR NUMACS))
('T (CDDR NUMACS))))
(DEFUN-ILE ACSMODESLOT (n)
(COND ((= n ##(NUMVALAC)) ACSMODE)
((= n ##(1+ (NUMVALAC))) (CDR ACSMODE))
('T (CDDR ACSMODE))))
(DEFUN-ILE NACSGET (mode)
(COND ((NULL mode) ##(1+ (NACS)))
('T ##(1+ (NUMNACS)))))
(DEFUN-ILE ILOCREG (x acx) (ILOCMODE x acx '(() FIXNUM FLONUM)))
(DEFUN-ILE ILOCNUM (x acx) (ILOCMODE x acx '(FIXNUM FLONUM)))
(DEFUN-ILE ILOCF (x) (ILOCMODE x 'FRACF '(() FIXNUM FLONUM)))
(DEFUN-ILE ILOCN (x) (ILOCMODE x 'ARGNO '(() FIXNUM FLONUM)))
(DEFUN-ILE FREACB () (FREEREGAC 'FRACB))
(DEFUN-ILE FREAC () (FREEREGAC 'FRAC))
(COMMENT SOME LOAD TIME HACS)
(AND (NOT (STATUS FEATURE SAIL)) (PUTPROP 'EREAD (GET 'UREAD 'FSUBR) 'FSUBR))
(AND *PURE
(SETQ GOBRKL PUTPROP
PUTPROP (APPEND '(STATUS SSTATUS INST INSTN IMMED CARCDR NUMBERP
ARITHP NOTNUMP CONTAGIOUS COMMU ACS CONV MINUS
BOTH FLOATI P1BOOL1ABLE FUNTYP-INFO ARGS)
PUTPROP)))
(SETSYNTAX '/& 'MACRO 'MACR-AMP-FUN)
(AND (NOT (EQ COMPLRVERNO 'INTERPRETER))
(SETQ NORET 'T)
(GETSP 36000.))
(COMMENT INITIALIZING FUNCTIONS)
(DEFUN INITIALIZE FEXPR (L)
(SSTATUS FEATURE COMPLR)
(SSTATUS FEATURE NCOMPLR)
(SETQ ITSP (STATUS FEATURE ITS))
(SETQ SAILP (STATUS FEATURES SAIL))
(SETQ OBARRAY (SETQ SOBARRAY (GET 'OBARRAY 'ARRAY)))
(SETQ READTABLE (SETQ SREADTABLE (GET 'READTABLE 'ARRAY)))
(COND ((STATUS FEATURE NO-EXTRA-OBARRAY)
(SETQ CREADTABLE READTABLE COBARRAY OBARRAY))
('T (SETQ CREADTABLE (ARRAY () READTABLE 'T))
(SETQ OBARRAY (SETQ COBARRAY (ARRAY () OBARRAY 'IOBARRAY)))
(MAPC 'INTERN
'(
*EXPR *FEXPR *LEXPR @DEFINE ARRAY* ARRAYOPEN ASSEMBLE
CHOMPHOOK CLOSED CMSGFILES COBARRAY COMPILE COMPLR
COMPLRVERNO COUTPUT CREADTABLE DIRECTORY DISOWNED
EOC-EVAL EVAL-WHEN EXPR-HASH FASL FIXSW FLOSW
GAG-ERRBREAKS GENPREFIX GOFOO MACROLIST
MACROS MAKLAP MAPEX MSDEV MSDIR MUZZLED NO-EXTRA-OBARRAY
NCOMPLR NOLAP NOTYPE NUMFUN NUMVAR ONMLS OWN-SYMBOL
RECOMPL SOBARRAY SPECIAL SPECIALS SPLITFILE SQUID
SREADTABLE SWITCHTABLE SYMBOLS TOPLEVEL TTYNOTES
UNDFUNS UNFASLCOMMENTS UNSPECIAL YESWARNTTY
))
(SETQ OBARRAY SOBARRAY)))
#(LET ((PROP (LSUB '(MACRO SPECIAL ARGS *EXPR *FEXPR *LEXPR
NUMVAR NUMFUN *ARRAY OHOME)
L))
(Z () ))
(MAPATOMS '(LAMBDA (Y)
(LREMPROP Y PROP) ;Remove compilation
(COND ((SETQ DATA (GET Y 'FUNTYP-INFO)) ;properties.
(AND (NOT (GET Y (CAR DATA)))
(ARGS Y (CDR DATA))))
((NOT (SYSP Y)) (ARGS Y () )))
(AND (BOUNDP Y) ;SPECIALize the
(NOT (MEMQ Y '(T NIL))) ;system varialbes
(SETQ DATA Y)
(MEMQ 'VALUE (STATUS SYSTEM DATA))
(PUSH Y Z))))
(APPLY 'SPECIAL Z)
(AND (STATUS FEATURE FASLAP) (FASLINIT)) )
(PUTPROP 'LET '|LET MACRO| 'MACRO)
(PUTPROP '%HUNK3 '(() . 3) 'ARGS)
(PUTPROP '%HUNK4 '(() . 4) 'ARGS)
(SETQ PRINLEVEL (SETQ PRINLENGTH (SETQ *RSET () )))
(SETQ BASE 8. IBASE 8. *NOPOINT 'T)
(SETQ COMPILATION-FLAGCONVERSION-TABLE
'((EXPR . SUBR) (FEXPR . FSUBR) (LEXPR . LSUBR)))
(SETQ SPECVARS () GENPREFIX '(/| G) GFYC 0 P1GFY ()
CLOSED () FIXSW () FLOSW () MACROLIST ()
GAG-ERRBREAKS () RNL () CFVFL ()
UNDFUNS () P1LLCEK () LAPLL () ROSENCEK ()
FASLPUSH () RECOMPL () CMSGFILES () LAP-INSIGNIF 'T
EOC-EVAL () COMPILER-STATE 'TOPLEVEL CHOMPHOOK ()
TOPFN () ONMLS () READ () MSDEV 'DSK MSDIR ()
CL () CLEANUPSPL 0 FILESCLOSEP () IMOSAR () )
#(SETUP-CATCH-PDL-COUNTS)
(SETQ SWITCHTABLE
(APPEND '(
(/$ FLOSW ()) (/+ FIXSW ())
(A ASSEMBLE () )
(B SWITCH-B ())
(C CLOSED () )
(D DISOWNED () )
(E EXPR-HASH () )
(F FASL ##(AND (MEMQ COMPILER-STATE '(MAKLAP DECLARE)) 'T))
(G GAG-ERRBREAKS () )
(H SWITCH-H ())
(I INITIALIZE () )
(J SWITCH-J ())
(K NOLAP ##(AND (MEMQ COMPILER-STATE '(MAKLAP DECLARE)) 'T))
(L SWITCH-L ())
(M MACROS () )
(N SWITCH-N ())
(O ARRAYOPEN T)
(P SWITCH-P ())
(Q SWITCH-Q ())
(R SWICTH-R ())
(S SPECIALS () )
(T TTYNOTES ##(AND (NOT (MEMQ COMPILER-STATE
'(MAKLAP DECLARE))) 'T))
(V SWITCH-V ())
(W MUZZLED () )
(X MAPEX () )
(Y YESWARNTTY ##(AND (NOT (MEMQ COMPILER-STATE
'(MAKLAP DECLARE))) 'T) )
(Z SYMBOLS () )
)
()))
(PUSH (COND (SAILP '(U UNFASLCOMMENTS () ))
('T '(U UNFASLCOMMENTS T)))
SWITCHTABLE)
(MAPC '(LAMBDA (X) (SET (CADR X) (CADDR X))) SWITCHTABLE)
(MAPC '(LAMBDA (X) (SET X (COPYSYMBOL X () )))
'(PROGN GOFOO NULFU COMP CARCDR ARGLOC SQUID MAKUNBOUND))
(PUTPROP SQUID '(LAMBDA (GL) (LIST 'QUOTE GL)) 'MACRO)
(SETQ QSM (LIST (LIST 'QUOTE (LIST SQUID MAKUNBOUND))))
(SETQ STSL (LIST (STATUS STATUS) (STATUS SSTATUS)))
(SETQ ARGLOC (LIST ARGLOC) CLPROGN (LIST PROGN))
(SETQ CAAGL (LIST (LIST (CONS MAKUNBOUND ARGLOC) 1)
(LIST (CONS MAKUNBOUND ARGLOC) 2)))
(SETQ MAPSB (NCONC (MAPCAR 'LIST '(VL EXIT USR PVR STSL))
(LIST (CONS 'GOFOO GOFOO))))
(SETQ COMAL (SUBST '() 'NIL '((NIL . NIL) (FIXNUM . FIXNUM) (FLONUM . FLONUM) (T))) )
(RPLACD (CAR COMAL) (CAR COMAL)) ;Sets up infinite
(RPLACD (CADR COMAL) (CADR COMAL)) ; type lists for COMARITH
(RPLACD (CADDR COMAL) (CADDR COMAL))
(FIXNUM BASE IBASE BPORG BPEND TTY) ;Some known declarations
(FIXNUM (LENGTH) (RANDOM) (EXAMINE FIXNUM) (LISTEN) (RUNTIME)
(GETCHARN NOTYPE FIXNUM) (FLATSIZE) (FLATC) (LSH) (ROT) (IFIX)
(↑ FIXNUM FIXNUM) (\\ FIXNUM FIXNUM) (SXHASH) (TYIPEEK) (TYI)
(HAULONG))
(FIXNUM (IN) (LINEL) (PAGEL) (CHARPOS) (LINENUM) (PAGENUM) (LENGTHF))
(PUTPROP 'BOOLE (CONS (CADR COMAL) (CONS 'FIXNUM (CADR COMAL))) 'NUMFUN)
(FLONUM (SIN) (COS) (SQRT) (LOG) (EXP) (ATAN) (TIME)
(↑$ FLONUM FIXNUM) (FSC) (FLOAT))
(NOTYPE (GETCHAR NOTYPE FIXNUM) (CXR FIXNUM) (DEPOSIT FIXNUM))
(PUTPROP PROGN 'T '*LEXPR)
(ARRAY* (NOTYPE OBARRAY 1 READTABLE 1))
(SSTATUS TTYINT '/≡ 'INT-↑↑-FUN)
(SETQ OBARRAY ##(COND ((MEMQ COMPILER-STATE '(MAKLAP DECLARE)) 'COBARRAY)
('SOBARRAY)))
(SETQ READTABLE ##(COND ((MEMQ COMPILER-STATE '(MAKLAP DECLARE)) 'CREADTABLE)
('SREADTABLE)))
(GCTWA))
;;; Function for & macro char
(DEFUN MACR-AMP-FUN ()
((LAMBDA (OBARRAY READTABLE)
(COND ((= (TYIPEEK) ##(INVERSE-ASCII '/&))
(TYI)
(SETQ OBARRAY SOBARRAY READTABLE SREADTABLE)))
(READ))
COBARRAY CREADTABLE))
;;; Function for control-↑ interrupt
(DEFUN INT-↑↑-FUN N
(SETQ SAVED-ERRLIST ERRLIST ERRLIST () N (ARG 2))
(SSTATUS TOPLEVEL '(INT-↑↑-TOPLE))
(DO () ((OR (= (LISTEN) 0) (= (TYI) N))))
(↑G))
(DEFUN INT-↑↑-TOPLE () ;Starts up MAKLAP from ↑↑
#(ERL-SET)
(SSTATUS TOPLEVEL () )
(COMPLRVERNO)
(NOINTERRUPT () )
(MAKLAP))
(DEFUN DB FEXPR (L) ;Setup for debugging
L
(SETQ SAVED-ERRLIST ERRLIST ERRLIST () )
(SSTATUS TOPLEVEL '(DB-TOPLE))
(↑G))
(DEFUN DB-TOPLE ()
(SSTATUS UUOLI)
#(ERL-SET)
(*RSET (NOUUO 'T))
(SETQ OBARRAY SOBARRAY READTABLE SREADTABLE)
(SETQ ↑W (SETQ ↑R () ))
(SETQ ERRSET (FUNCTION (LAMBDA (X) X (BREAK ERRSET))))
(PROG (L)
A (COND ((NOT (GET 'BS 'FSUBR))
(COND (ITSP (SETQ L '((DSK LIBLSP) BS FASL)))
((PROBEF (SETQ L '((DSK) BS FAS))))
('T (PRINC '|/
PLEASE LOAD BS FASL! /
|)
(BREAK LOAD)
(GO A)))
(LOAD L))))
(SSTATUS TOPLEVEL () ))
(DEFUN CDUMP N
(SETQ ERRLIST () SAVED-ERRLIST '((COMPLRVERNO)))
(SSTATUS TOPLEVEL '(COMPLR-TOPLE))
(GC)
(APPLY 'SUSPEND (LISTIFY N))
(THROW () ())
;;(COMMENT Hopefully, this goes to a TOPLEVEL user of COMPLR-TOPLE)
)
(DEFUN COMPLR-TOPLE () ;Initial TOPLEVEL loop
(SETQ OBARRAY COBARRAY READTABLE CREADTABLE)
(SSTATUS TOPLEVEL () )
#(ERL-SET)
#(LET ((UID (STATUS USERID))
(USN (COND ((STATUS STATUS HOMED) (STATUS HOMED)) ((STATUS UDIR))))
(MSGFILES '(T)) FILE OFILE)
(SETQ OFILE (CONS (LIST 'DSK USN)
(COND (ITSP (CONS UID '(COMPLR)))
('(COMPLR INI))))) ;`((DSK ,usn) ,uid COMPLR)
(AND (COND ((SETQ FILE (PROBEF OFILE)))
(ITSP
(RPLACA (CDR OFILE) '*)
(AND (SETQ FILE (CAR (ERRSET (OPEN OFILE '(NODEFAULT)) () )))
(SETQ FILE (TRUENAME FILE)))
FILE))
(PRINC '|LOADING COMPLR INITIALIZATION FILE FOR |)
(PRINC (COND ((OR (EQ (CADR OFILE) '*) (NOT ITSP)) USN)
(UID)))
(PROG2 (TERPRI) 'T)
(AND (ATOM (ERRSET (LOAD FILE) 'T))
(PRINC '| *** ERRORS DURING LOADING *** BEWARE!| TYO)))
(SETQ DEFAULTF (CONS (CAR OFILE) (COND (ITSP '(FOO >))
(SAILP '(FOO |←←←|))
('(FOO LSP))))))
(COND ((SETQ DATA (STATUS JCL))
((LAMBDA (WINP JCL-LINE)
(SETQ WINP
(ERRSET
(PROG (M L LL)
(SETQ L DATA)
A (AND (< (SETQ M (GETCHARN (CAR L) 1)) 27.) ;Flush control chars
(NOT (= M 17.)) ;[except ↑Q] from
(SETQ L (CDR L)) ;front of JCL list
(GO A))
(SETQ LL (LIST 35397.)) ;total random no.
B (SETQ M (GETCHARN (CAR L) 1))
(PUSH (COND ((AND (< M 123.) (> M 96.))
(- M 32.)) ;Uppercaseify rest
(M)) ;of line
LL)
(AND (SETQ L (CDR L)) (GO B))
C (AND (< (CAR LL) 27.)
(SETQ LL (CDR LL)) ;Flush control chars
(GO C)) ;from end of line
(APPLY 'MAKLAP LL))
'T ))
(COND ((ATOM WINP)
(COND (WINP (PRINC '| *** ERRORS FROM JCL COMMAND *** /
;JCL = "|)
(PRINC (MAKNAM JCL-LINE))
(PRINC '|"/
|)
(BREAK JCL))
('T (PRINC '| *** ERRORS - RANDOMNESS IN COMPLR-TOPLE|)
(BREAK COMPLR-TOPLE))) ))
(INT-↑↑-TOPLE))
() DATA))
('T (COMPLRVERNO) (MAKLAP))) )
(DEFUN COMPLRVERNO () ;PRINCs version number
(SETQ ↑W (SETQ ↑R (SETQ ↑Q () )))
(PRINC '|/
LISP COMPILER |)
(PRINC COMPLRVERNO)
(PRINC '| [BY |)
(PRINC '##(COND ((MEMQ COMPILER-STATE '(MAKLAP DECLARE)) COMPLRVERNO)
('INTERPRETER)))
(PRINC '|]|)
() )
(COMMENT COMPILE AND COMP FUNCTIONS)
(DEFUN COMPILE (NAME-ARG FLAG EXP RNL P1GFY)
(PROG (LOUT LOUT1 ATPL ATPL1 P1CNT LOCVARS CNT LSUBRF FL BVARS
VL EFFS EXLDL P1LL CONDP LMBP P1CSQ P1LSQ CTAG HLAC SFLG
PROGP P1PSQ GONE2 GOBRKL NLNVS AL NAME LDLST SPLDLST P2P
SPFL ARGNO PVRL OPVRL LPRSL VGOL GL PRSSL PNOB DPL
KTYPE PKTYP MODELIST ARITHP REGACS NUMACS ACSMODE REGPDL
FXPDL FLPDL OLVRL SPECVARS TAKENAC1 UNSFLST PROGUNSF
CONDUNSF NLNVTHTBP ERRFL ROSENCEK P1LLCEK *NOPOINT NARGS
MARR-LOSS FOOSUBRP SYSFUNP P1SPECIALIZEDVS L-END-CNT)
(SETQ CNT 1)
(COND ((ATOM NAME-ARG) (SETQ NAME NAME-ARG NAME-ARG () ))
('T (SETQ NAME (CAR NAME-ARG))
(SETQ FOOSUBRP (NOT (MEMQ (CADDR NAME-ARG)
'(SUBR FSUBR LSUBR))))))
(COND ((NOT P1GFY)
(GENSYM 0)
(SETQ TOPFN NAME)
(AND (SETQ SYSFUNP (SYSP NAME))
(OR (NULL NAME-ARG) (NOT FOOSUBRP))
(PROG2 (ARGS NAME ()) 'T (SETQ SYSFUNP 'T))
(WARN NAME |Redefining system function|))))
(COND ((NULL (EQ (CAR EXP) 'LAMBDA)) (DBARF EXP |No function| 4 6))
((AND (CADR EXP) (ATOM (CADR EXP)))
(COND ((NOT FOOSUBRP)
(AND (OR (GETL NAME '(*EXPR *FEXPR))
(NOT (MEMQ FLAG '(EXPR LEXPR))))
(WRNTYP NAME))
(ARGS NAME () )
(AND (MEMQ SYSFUNP '(T () ))
(PUTPROP NAME 'T '*LEXPR))))
(SETQ LSUBRF (SETQ FLAG 'LEXPR))
(SETQ EXP (CONS (CAR EXP) (CONS (LIST (CADR EXP)) (CDDR EXP))))))
(COND (LSUBRF)
((> (SETQ NARGS (LENGTH (CADR EXP))) #(NACS))
(SETQ LSUBRF 'LSUBR FLAG 'LEXPR) ;CONVERT LONG EXPR TO LSUBR
(COND ((NOT FOOSUBRP)
(LREMPROP NAME '(*EXPR *FEXPR))
(COND ((AND (NOT P1GFY) (MEMQ SYSFUNP '(T () )))
(PUTPROP NAME 'T '*LEXPR)
(PUTPROP NAME (CONS NARGS NARGS) 'ARGS)
(SETQ AL (CONS NARGS NARGS)))))))
((COND (FOOSUBRP () )
((EQ FLAG 'EXPR)
(COND ((AND (NOT P1GFY) (NOT SYSFUNP))
(SETQ AL (CONS () NARGS))
(P1ACK NAME 'SUBR AL NARGS)))
(SETQ FL '*EXPR)
'T)
((EQ FLAG 'FEXPR)
(REMPROP NAME 'ARGS)
(SETQ FL '*FEXPR)
'T))
(AND (SETQ SPFL (GETL NAME '(*EXPR *FEXPR *LEXPR)))
(NOT (EQ FL (CAR SPFL)))
(WRNTYP NAME))
(PUTPROP NAME 'T FL))
((EQ FLAG 'LEXPR) (SETQ LSUBRF 'LSUBR FLAG 'LEXPR)))
(SETQ EXP (P1LMBIFY (CDDR EXP)
'P1LL
(SETQ P1LL (CADR EXP))
NAME
(CDDR (AND (NOT FOOSUBRP)
(SETQ KTYPE (GET NAME 'NUMFUN))))))
(AND KTYPE (SETQ KTYPE (CADR KTYPE)))
(MAPC '(LAMBDA (X)
(COND ((AND X (NOT (SPECIALP X)) (NULL (VARMODE X)))
(PUSH X UNSFLST))))
P1LL)
(SETQ EXP (P1GLM P1LL EXP))
(SETQ UNSFLST (LSUB UNSFLST (P1SPECIALIZEDVS)))
(AND (SETQ FL (UUVP 'P1LL)) (WARN FL |Unused LAMBDA variables|))
(AND ERRFL (ERR 'DATA))
(AND NLNVS (NLNVASG (MAPCAR 'CAR NLNVS)))
(MAPC '(LAMBDA (X) (PUTPROP (CAR X) () 'OHOME)) LOCVARS)
(SETQ LOUT (LIST 'LAP
NAME
(COND ((NULL NAME-ARG)
(CDR (ASSQ FLAG COMPILATION-FLAGCONVERSION-TABLE)))
((NULL (CDDR NAME-ARG)) (CADR NAME-ARG))
((CADDR NAME-ARG)))))
(SETQ LOUT1 (SETQ ATPL1 'FOO)) ;ATPL is still ()
(AND (NOT (= BASE 8.))
((LAMBDA (B BASE)
(OUTPUT (SUBST B 'BASE '(EVAL (SETQ IBASE BASE))))
(PROG2 (|Oh, FOO!|) (|Oh, FOO!|))
(SETQ *NOPOINT () ))
BASE 8.))
(AND AL #(OUTFS 'ARGS NAME AL))
(COND (SYMBOLS (OUTPUT '(SYMBOLS T))
(COND ((> (FLATC NAME) 5) (OUTPUT (GENSYM))))))
(AND KTYPE
(OUTPUT (COND ((EQ LSUBRF 'LEXPR)
(COND ((EQ KTYPE 'FIXNUM) '(JSP D (*LCALL -1)))
('(JSP D (*LCALL -2)))))
((EQ LSUBRF 'LSUBR)
(OUTPUT (COND ((EQ KTYPE 'FIXNUM) '(SKIPA T (% 0 0 FIX1A)))
('(SKIPA T (% 0 0 FLCONS)))))
(SETQ MARR-LOSS (LIST (GENSYM)))
'(MOVEI T 0))
((EQ KTYPE 'FIXNUM) '(PUSH P (% 0 0 FIX1)))
('(PUSH P (% 0 0 FLOAT1))))))
(SETQ HLAC (SETQ LPRSL (SETQ TAKENAC1 0)))
(SETQ P1CNT CNT CNT 1 BVARS () PNOB () P2P 'T)
(SETQ AL #(INITIALSLOTS))
(SETQ REGACS (APPEND (CAR AL) () ))
(SETQ NUMACS (APPEND (CADR AL) () ))
(SETQ ACSMODE (APPEND NUMACS () ))
(SETQ REGPDL () FXPDL () FLPDL () )
(SETQ ARGNO (COND (KTYPE #(NUMVALAC)) (1)))
(COND ((EQ LSUBRF 'LEXPR) (OUTPUT '(JSP D *LCALL)))
((EQ LSUBRF 'LSUBR)
(DO I NARGS (1- I) (ZEROP I) (PUSH () REGPDL))
(COND (MARR-LOSS
(SETQ FXPDL (LIST MARR-LOSS))
(PUSH MARR-LOSS LDLST)
(OUTPUT '(PUSH FXP T)))))
((AND (EQ FLAG 'FEXPR) (CDAR (CDDDDR EXP)))
(OUTPUT '(EXCH 1 2))
(OUTPUT '(MOVE TT SP))
(OUTPUT '(JSP T FIX1A))
(OUTPUT '(EXCH 1 2))))
(SETQ FL (CDDDDR EXP))
(CNPUSH (APPEND NLNVTHTBP (CAR (CDDDDR FL))) () )
(SETQ BVARS (APPEND (CAR FL) BVARS) ;LSUBRF = +1 => SUBR
LSUBRF (COND ((EQ LSUBRF 'LSUBR) -1) (+1))) ;LSUBRF = -1 => LSUBR
(SETQ SPFL SFLG)
(DO ((AC (LSH (1+ LSUBRF) -1) (+ AC LSUBRF))
(X (COND ((< LSUBRF 0) (REVERSE (CAR FL))) ((CAR FL))) (CDR X))
(MODE))
((NULL X))
(COND ((AND (CAR X) (SPECIALP (CAR X)))
(COND ((NULL SPFL)
(SETQ SPFL 'T)
(CPUSH ##(+ (NUMVALAC) 2))
(OUTPUT '(JSP T SPECBIND))))
(OSPB AC (CAR X))))
(COND ((NULL (CAR X)))
((> LSUBRF 0) (CONT AC (LIST (CAR X)))) ;SUBR TYPE
((NOT (SPECIALP (CAR X)))
(CONT AC (COND ((SETQ MODE (VARMODE (CAR X)))
(PUSH (CONS AC (CONS (LIST (CAR X)) MODE)) DPL)
())
('T (LIST (CAR X))))))))
(MAPC '(LAMBDA (L) (OPUSH (CAR L) (CADR L) (CDDR L))) DPL)
(SETQ EXP (CADDDR (CDDR EXP)))
(COND (DPL (SETQ SFLG () )) ;DPL is the delayed-pushes list
((SETQ SPFL (PROGHACSET SPFL EXP))))
(LOADAC (COMP EXP) ARGNO 'T) ;Since PNOB has been (), this should
; not cause a PDLNMK
(AND KTYPE
(SETQ FL (GETMODE0 ARGNO 'T () ))
(NOT (EQ KTYPE FL))
(WARN NAME |This function was declared numerical,
but the resultant type is incorrect|))
(COND (MARR-LOSS
(OUT1 'SKIPE 'T (ILOC1 () MARR-LOSS 'FIXNUM))
(OUTPUT '(JSP T 0 T))
(|Oh, FOO!|)
(REMOVE MARR-LOSS)))
(SETQ FL
(COND (SPFL '(JRST 0 UNBIND))
((AND (NOT (OR FXPDL FLPDL))
(NOT ATPL))
(COND ((AND (SETQ AL (ASSOC (CAR LOUT)
'((PUSHJ . JRST) (NCALL . NJCALL)
(CALL . JCALL) (NCALLF . NJCALF)
(CALLF . JCALLF))))
(COND ((OR (NULL (CDDDR LOUT))
(NOT (MEMQ '@ LOUT))
(NOT (NUMBERP (CADDDR LOUT)))))
((ZEROP (CADDDR LOUT))
(NOT (EQ (CADR (CDDDR LOUT)) 'P)))
((NOT #(PDLLOCP (CADDDR LOUT))))))
(SETQ AL (CONS (CDR AL)
(COND ((EQ (CDR AL) 'JRST) (CONS 0 (CDDR LOUT)))
((CDR LOUT)))))
(SETQ LOUT (SETQ ATPL 'FOO))
AL)
((AND (EQ (CAR LOUT) 'JSP) (EQUAL LOUT '(JSP T PDLNMK)))
(SETQ LOUT (SETQ ATPL 'FOO))
'(JRST 0 PDLNKJ))
('T '(POPJ P))))
('T '(POPJ P))))
(CONT ARGNO '(NIL . TAKEN))
(RESTORE #(INITIALSLOTS))
(OUTPUT FL)
(MAPC 'OUTG VGOL)
(COND (LDLST (BARF LDLST |Left on LDLST|)))
(AND SYMBOLS (NOT (EQ SYMBOLS 'T)) (OUTPUT '(SYMBOLS T)))
(OUTPUT () ) (OUTPUT () ) (OUTPUT () )
(COND ((NOT FASLPUSH) (ICOUTPUT GOFOO) (ICOUTPUT GOFOO)))
(GCTWA)
(COND ((NOT (= CNT P1CNT))
(BARF (LIST P1CNT CNT) |Unequal count|)))
(RETURN NAME)))
;;; Results from the "COMP" type functions can be
;;; () if computing for effects only; otherwise, is
;;; (QUOTE MUMBLE)
;;; (VAR . CNT)
;;; (G0005 . () )
;;; where G0005 is either 1) The internal name of some computational result, or
;;; 2) A carcdr'ing, like 1) above, but which may be delayed
(DEFUN COMP (X) ((LAMBDA (EFFS) (COMP0 X)) () )) ;For value
(DEFUN COMPE (X) ((LAMBDA (EFFS PNOB) (COMP0 X)) 'T 'T)) ;For effects
(DEFUN COMP1 (X) (COMPW X () 1)) ;For value, into accumulator 1
(DEFUN COMPW (X EFFS ARGNO) (COMP0 X)) ;Can specify effects and accumulator number
(DEFUN COMPR (X MODE OEFFS OPNOB) ;This seems to be useful in several places
(COND (MODE (COMPW X () (FREENUMAC)))
('T ((LAMBDA (EFFS PNOB ARGNO) (COMP0 X))
()
OPNOB
(COND (OEFFS 1)
((NOT #(NUMACP-N ARGNO)) ARGNO)
(#(FREAC)))))))
(DEFUN COMP0 (X) ;The basic "CHOMP"
((LAMBDA (Y MODE)
(COND ((EQ MODE 'SYMBOL) ;"CHOMPING" a variable
(SETQ CNT (ADD1 CNT))
(COND ((NULL EFFS)
(SETQ Y (CONS X CNT))
(COND ((SPECIALP X) (PUSH Y SPLDLST))
((ILOC0 Y (SETQ MODE (VARMODE X))))
((AND MODE (ILOC0 Y () )))
((COND ((OR (MEMQ X PVRL) (MEMQ X OPVRL))
(AND MODE (PDERR X |Uninitialized number variable|))
'T)
((MEMQ X OLVRL)))
(SETQ Y (COND ((NULL MODE) '(QUOTE () ))
((EQ MODE 'FIXNUM) '(QUOTE 0))
('T '(QUOTE 0.0)))))
((BARF Y |What kind of variable is this - COMP0|))))))
((NOT (EQ MODE 'LIST)) (BARF X |What is this cruft - COMP0|))
((EQ (CAR X) 'QUOTE) (SETQ Y X)) ;"CHOMPING" quoted frob
((AND (NOT (ATOM (CAR X))) (EQ (CAAR X) CARCDR)) ;"CHOMPING" a carcdring
(COND (EFFS (COMP0 (CADR X)))
('T (SETQ Y (COND ((NOT (SYMBOLP (CADR X)))
(COND (#(NUMACP-N ARGNO) (COMP1 (CADR X)))
((COMP0 (CADR X)))))
((SPECIALP (CADR X))
(CAR (PUSH (CONS (CADR X) (SETQ CNT (ADD1 CNT)))
LDLST)))
('T (COMP0 (CADR X)))))
(PUSH (XCONS (CONS (CDAR X) Y)
(SETQ Y (GENSYM)))
SPLDLST)
(SETQ Y (LIST Y)))))
('T (SETQ Y (COMPFORM X))))
(COND ((NULL EFFS) (PUSH Y LDLST) Y)))
() (TYPEP X)))
(DEFUN COMPFORM (F)
(PROG (X Y Z FNARGS VALAC NARGS TEM T1 CCSLD ARRAYP JSP UNSAFEP)
(SETQ X (CAR F) Y (CDR F) VALAC 1)
A (AND (SETQ T1 (NOT (ATOM X))) ;Non-Atomic function forms
(COND ((EQ (CAR X) 'LAMBDA) (RETURN (COMLAM X Y)))
((EQ (CAR X) COMP)
(AND (SYMBOLP (CDDR X))
(SPECIALP (CDDR X))
#(NO-DELAYED-SPLDS))
(SETQ FNARGS (COMP1 (CDDR X)))
(COND (CCSLD)
((AND (NULL Y)
(OR (NULL SPLDLST)
(PROG2 (CLEANUPSPL 'T)
(OR (NULL SPLDLST)
(AND (NULL (CDR SPLDLST))
(EQ FNARGS (CAAR SPLDLST))))))))
('T #(NO-DELAYED-SPLDS)))
(SETQ X (COND ((EQ (CADR X) 'FUNCALL)
(COND ((> (LENGTH Y) #(NACS))
(SETQ
VALAC
(COMLC (LIST COMP 'FUNCALL FNARGS)
Y
() ))
(GO CALLX)))
() )
((CDR X))))
(LOADACS (SETQ Z (ITEML Y () )) (SETQ NARGS (LENGTH Z)) () )
(SETQ TEM #(PDLLOCP (SETQ T1 (ILOCMODE FNARGS 'FRACF () ))))
(REMOVEB FNARGS)
(AND #(CLEARALLACS) TEM (SETQ T1 (ILOC0 FNARGS () )))
(COND ((NULL X)
(OUT1 (COND ((AND (OR #(NUMACP-N ARGNO) PNOB)
(VARBP (CAR FNARGS))
(SETQ F (OR (FUNMODE (CAR FNARGS))
(GET 'FNARGS 'NUMFUN)))
(SETQ F (CADR F)))
(RPLACA ACSMODE F) ;(SETMODE #(NUMVALAC) FOO)
(SETQ VALAC #(NUMVALAC))
'(NCALLF . NCALLF))
('(CALLF . CALLF)))
NARGS
T1))
('T (COND ((MEMQ (CAR X) '(FIXNUM FLONUM))
(OUT1 'MOVE #(NUMVALAC) T1)
(OUTPUT ##(SUBST (NUMVALAC) 'AC ''(PUSHJ P 1 AC)))
(RPLACA ACSMODE (CAR X))
(SETQ VALAC #(NUMVALAC)))
((OUT1 '(PUSHJ) 'P T1)))))
(AND TEM (|Oh, FOO!|))
(GO CALLX))
((NOT (EQ (CAR X) MAKUNBOUND)) (GO LOSTF))
((AND (EQ (CAR (SETQ X (CDR X))) 'FSUBR) (ATOM (CDR X)))
(AND (NOT (GET (CDR X) 'ACS)) #(NO-DELAYED-SPLDS))
(LOADAC (COMPW Y () 1) 1 () )
(SETQ X (CDR X))
(GO F-*))
((EQ (CAR X) '*MAP)
(COND ((CADR X) #(NO-DELAYED-SPLDS)) ;Mapping unknown funct
('T (CSLD () 'T () ))) ;Fun has no side-effects
(COND ((NOT (EQ (CADDR X) '*MAP))
(COMLC (CADDR X) Y () )
(GO CALLX)))
(LOADACS ((LAMBDA (EFFS ARGNO)
(LIST (COMP0 (CAR Y))
(COMP0 (PROG2 (SETQ ARGNO 1)
(CADR Y)))))
() 2)
2
() )
#(CLEARALLACS)
#(OUTFS 'PUSHJ 'P (CDDR X))
(GO CALLX))
((EQ (CAR X) 'RPLACD) (RETURN (COMRPLAC 'RPLACD Y 'T)))
((EQ (CAR X) 'MAKNUM)
((LAMBDA (ARGNO EFFS PNOB)
(SETQ Z (COMP0 (CAR Y)) Y ARGNO))
(COND (#(NUMACP-N ARGNO)
(SETQ TEM (COND ((NOT (DVP ARGNO)) ARGNO)
((NOT (ZEROP (SETQ TEM (FREENUMAC1)))) TEM)
(#(NUMVALAC))))
(FRAC5))
('T (SETQ UNSAFEP PNOB) (SETQ TEM () ) 1))
()
() )
(CPUSH (SETQ VALAC (OR TEM #(NUMVALAC))))
(SETQ Y #(ILOCREG Z Y))
(REMOVEB Z)
(AND #(ACLOCP Y) (CPUSH Y))
(CCSWITCH VALAC Y)
(SETMODE VALAC 'FIXNUM)
(COND ((NULL TEM)
(CPUSH 1)
(COND ((NOT PNOB)
(SETQ VALAC 1)
(OUTPUT '(JSP T FXCONS))
(RPLACA NUMACS () ))))) ;(CONT #(NUMVALAC) () )
(GO RETV))
((EQ X ARGLOC) ;bind to specific location
(SETQ VALAC (CAR Y)) ;mostly for use by CATCHALL
(GO RETV))
('T (GO LOSTF))))
(COND ((SETQ TEM (GETL X '(ARITHP NUMBERP NOTNUMP)))
(COND ((EQ (CAR TEM) 'ARITHP) (BARF F |ARITHP function in COMPFORM???|))
((AND EFFS (OR (NOT (EQ (CAR TEM) 'NOTNUMP))
(EQ (CADR TEM) 'NOTNUMP)))
(WARN F |You're losing some value here| 3 5)))
(COND ((NOT (EQ (CAR TEM) 'NUMBERP)) )
((EQ (CADR TEM) 'NOTYPE)
(COND ((COND ((MEMQ X '(EQ EQUAL))
(COND ((OR (EQ X 'EQ)
(MEMQ (CAR Y) '(FIXNUM FLONUM)))
(COMEQ Y () 'T)
'T)))
((MEMQ X '(GREATERP LESSP *GREAT *LESS))
(COND (#(KNOW-ALL-TYPES (CAR Y))
(COMGRTLSP F () 'T)
'T)))
((MEMQ X '(ZEROP PLUSP MINUSP ODDP))
(COND ((AND (NOT CLOSED)
(MEMQ (CAR Y) '(FIXNUM FLONUM)))
(COMZP F () 'T)
'T)))
((BARF F |Lost NOTYPE NUMBERP-function|)))
(BOOLOUT () () )
(GO RET-NO))
('T (SETQ F (CONS X (SETQ Y (CDR Y))))))
() )
((OR (EQ X 'FIX)
(NULL (CAR Y))
(AND CLOSED (NOT (ATOM (CAR Y))))) ;For closed-CALL arith
(SETQ F (CONS X (SETQ Y (CDR Y))))
() )
((MEMQ X '(ADD1 SUB1)) (RETURN (COMAD1SB1 X Y)))
((MEMQ X '(PLUS DIFFERENCE TIMES QUOTIENT)) (RETURN (COMARITH X Y)))
((MEMQ X '(*DIF *PLUS *TIMES *QUO HAULONG))
(AND #(KNOW-ALL-TYPES (CAR Y))
(RETURN (COND ((EQ X 'HAULONG) (COMHAULONG Y))
('T (COMARITH X Y)))))
(SETQ F (CONS X (SETQ Y (CDR Y))))
() )
((MEMQ X '(FIX FLOAT IFIX))
(RETURN (COMFIXFLT (COMPW (CADR Y) () #(NUMVALAC))
(COND ((EQ X 'FLOAT) 'FLONUM) ('FIXNUM)))))
((EQ X 'REMAINDER) (RETURN (COMREMAINDER (CDR Y))))
((MEMQ X '(ABS MINUS)) (RETURN (COMABSMINUS X Y))))))
(COND ((SETQ T1 (FUNTYP-DECODE X))
(COND ((EQ T1 'FSUBR) ;Compile for Special Forms
(COND ((EQ X 'COND)
(SETQ UNSAFEP (AND PNOB (CADDR Y)))
(COMCOND Y () () () )
(AND (NOT EFFS)
#(NUMACP-N ARGNO)
(NULL (CAR (SETQ TEM #(ACSMODESLOT ARGNO))))
(RPLACA TEM (COND ((NULL (SETQ Z (CADDDR Y)))
(BARF () |No type for COMCOND|))
((ATOM Z) Z)
((CADR Z)))))
(GO RET-NO))
((EQ X 'PROG)
(SETQ TEM (COMPROG Y))
(SETQ UNSAFEP (CADDR (CDDDDR Y)))
(AND #(NUMACP-N ARGNO) (SETMODE ARGNO (COND (TEM) ('FIXNUM))))
(GO RET-NO))
((EQ X 'SETQ) (RETURN (COMSETQ Y)))
((EQ X 'GO) (COMGO Y) (RETURN ''()))
((AND (EQ X 'ERR) (NULL (CDR Y)))
(LOADAC (COMP1 (CAR Y)) 1 'T)
(OUTPUT '(JRST 0 ERUNDO))
(GO RET))
((OR (EQ X 'COMMENT) (EQ X 'DECLARE))
(OUTPUT (CONS 'COMMENT Y))
(RETURN '(QUOTE COMMENT)))
((MEMQ X '(AND OR))
(COND ((NOT EFFS) (BARF F |AND or OR loss| 3 6)))
(CLEAR (CADR Y) 'T)
(SETQ Z (L2F (CDDDDR Y)))
(COND ((AND (NULL (CDDR Z))
(NOT (ATOM (CAR Z)))
(SETQ T1 (COND ((EQ (CAAR Z) 'GO)
(AND (ATOM (CADAR Z))
(ADR (CADAR Z))))
((EQ (CAAR Z) 'RETURN)
(AND (QNILP (CADAR Z))
(GENTAG 'EXITN)))))
(EASYGO))
(BOOL1 (CADR Z) T1 (EQ X 'AND))
(SETQ CNT (PLUS 2 CNT)))
('T (BOOL2LOOP (CDR Z)
(SETQ T1 (LEVELTAG))
(EQ X 'OR))
(COMPE (CAR Z))
(SETQ CNT (PLUS 2 CNT))
(OUTTAG T1)))
(DIDUP (CADDR Y))
(GO RET))
((EQ X 'SIGNP) (COMSIGNP Y () () ) (GO RETV))
((MEMQ X '(ERRSET CATCH *CATCH CATCH-BARRIER
%CATCHALL %PASS-THRU))
(SETQ Z (COMERSET X Y))
(COND ((EQ X 'ERRSET) (RETURN Z))
('T (GO RETV))))
((EQ X 'STORE)
(COND ((AND ARRAYOPEN
(ATOM (CAAR Y))
(COND ((AND (SETQ ARRAYP (GET (CAAR Y) '*ARRAY))
(NOT (EQ ARRAYP 'T)))
(SETQ X (CAAR Y) Z (CDAR Y))
(AND (SETQ T1 (GET X 'NUMFUN)) (SETQ T1 (CADR T1)))
(SETQ TEM (COMPR (CADR Y) T1 () () ))
'T)
((EQ (CAAR Y) 'ARRAYCALL)
(SETQ T1 (CADAR Y)
TEM (COMPR (CADR Y) T1 () () )
X (COMP1 (CADDAR Y))
Z (CDDDAR Y)
ARRAYP () )
'T)))
(SETQ Z (NREVERSE (ITEML Z '(FIXNUM FIXNUM FIXNUM
FIXNUM FIXNUM FIXNUM FIXNUM))))
(SETQ VALAC (COM-AREF X Z TEM T1 ARRAYP)))
(((LAMBDA (V LOC TAKENAC1)
(CONT TAKENAC1 () )
(REMOVE LOC)
(LOADAC V 1 'T)
(CLEARNUMACS)
(OUTPUT '(JSP T *STORE)))
(COMP1 (CADR Y))
(COMPW (CAR Y) 'T 1)
(+ #(NUMVALAC) 2))))
(GO RETV))
((EQ X 'ARRAYCALL)
(SETQ VALAC (COMARRAY (COMP1 (CADR Y)) (CDDR Y) () (CAR Y)))
(GO RETV))
((EQ X 'LSUBRCALL)
(SETQ VALAC (COMLC (LIST COMP (CAR Y) (COMP1 (CADR Y)))
(CDDR Y)
() ))
(GO CALLX))
((EQ X 'PROGV)
(SETQ TEM (COMPW (CAR Y) () 5) T1 (COMP1 (CADR Y)))
(AND (NULL (ILOCMODE TEM 5 () )) (DBARF F |Bad variables list|))
(LOADAC TEM 5 () ) ;Maybe should be safe things?
(LOADAC T1 1 () )
#(CLEARALLACS)
(OUTPUT '(JSP T VBIND))
((LAMBDA (GOBRKL)
(SETQ TEM (COMPROGN (CDDR Y) EFFS))
(COND ((AND (NULL EFFS) (CDR TEM) (SPECIALP (CAR TEM)))
(LOADAC TEM ARGNO () )
(SETQ TEM () ))
('T (AND (NULL EFFS) #(ILOCN TEM))
(REMOVEB TEM))))
(CONS '( UNBIND . () ) GOBRKL))
(OUTPUT '(PUSHJ P UNBIND))
(COND (TEM (RETURN TEM)) ((GO RETV))))
('T (GO F-FORM))))
((EQ T1 'SUBR) ;Compile for SUBR type
(COND ((EQ X 'NULL) (COMNULL (CAR Y)) (GO RET-NO))
((EQ X 'RETURN)
(COMRETURN Y 'T)
(CONT PVR () )
(RETURN ''()))
((MEMQ X '(RPLACA RPLACD SETPLIST))
(RETURN (COMRPLAC X Y () )))
((AND (MEMQ X '(PRINC *PRINC))
(NOT (ATOM (CAR Y)))
(EQ (CAAR Y) 'QUOTE)
(STRTIBLE (CADAR Y))) ;### REMEMBER: P1 AND P1BASICBOOL1ABLE
(GO OUTSTRT))
((AND (SETQ TEM (GET X 'P1BOOL1ABLE))
(NOT (ATOM TEM)))
(COMTP F TEM () 'T 'T)
(GO RET-NO))
((EQ X 'SET)
((LAMBDA (NAME V ARGNO EFFS)
(CSLD 'T () () )
(SETQ NAME (COMP0 (CAR Y)))
(SETQ V (COMP0 (CADR Y)))
(LOADAC NAME 4 () )
(AND (SETQ NAME (GETMODE0 4 () () ))
(PDERR F |SET applied to numeric datum|))
(LOADAC V 1 'T)
(OUTPUT '(JSP T *SET)))
() () 1 () )
(GO RET))
((MEMQ X '(ROT LSH FSC)) (RETURN (COMSHIFTS X Y)))
((EQ X 'TYPEP)
(COND (EFFS (SETQ F (CADR F) X (CAR F) Y (CDR F)) (GO A)))
(COMTP F () () 'T 'T)
(GO RET-NO))
((EQ X 'ARG)
(COND ((NOT (EQ (CAAR Y) 'QUOTE))
(SETQ Z (COND (#(NUMACP-N ARGNO) (COMP1 (CAR Y)))
((COMP0 (CAR Y)))))
(AND EFFS (PROG2 (REMOVE Z) (GO RETV)))
(SETQ Z (LOADINSOMENUMAC Z))
#(OUTFS 'ADD Z 'ARGLOC)
(SETQ Y '((QUOTE 0)))
((LAMBDA (TAKENAC1) (CPUSH ARGNO)) Z)
(CONT Z () ))
((PROG2 (CPUSH ARGNO) (NULL (CADAR Y)))
(OUTPUT (CONS 'MOVE
(CONS ARGNO
(COND (#(NUMACP-N ARGNO)
'(@ (ARGLOC 1)))
('T '((ARGLOC 1)))))))
(SETQ UNSAFEP 'T)
(GO RET-NO))
('T (COND ((SETQ Z (MEMQ ARGLOC REGACS))
(SETQ Z (- (+ 1 #(NACS)) (LENGTH Z))))
((SETQ Z (MEMQ ARGLOC NUMACS))
(SETQ Z (- (+ #(NUMVALAC) #(NUMNACS)) (LENGTH Z))))
('T (CONT (SETQ Z #(FREACB)) ARGLOC)
#(OUTFS 'MOVE Z 'ARGLOC)))))
(SETQ Z (LIST (CADAR Y) Z))
(OUTPUT (COND ((NOT #(NUMACP-N ARGNO))
(SETQ UNSAFEP 'T)
(CONS 'HRRZ (CONS ARGNO Z)))
('T (CONS 'MOVE (CONS ARGNO (CONS '@ Z))))))
(GO RET-NO))
((EQ X '*THROW)
((LAMBDA (EFFS ARGNO PNOB HLAC)
(SETQ TEM (COMP0 (CAR Y))
ARGNO 1
T1 (COMP0 (CADR Y))
HLAC 2)
(LOADAC TEM 2 'T) ;The tag name
(LOADAC T1 1 'T)) ;The value
() 2 () 0)
#(CLEARALLACS)
(OUTPUT '(JRST 0 (ERUNDO -1)))
(GO RET))
((EQ X 'PLIST)
(SETQ T1 #(ILOCN (SETQ Z (COMP0 (CAR Y))))
TEM (COND ((NOT (NUMBERP T1)) () )
((> T1 0) 'PLUSP)
('T)))
(REMOVEB Z)
(SETQ VALAC (COND ((EQ TEM 'PLUSP) (CPUSH T1) T1)
((NOT (DVP ARGNO)) ARGNO)
(#(FREAC))))
(COND ((AND (NULL TEM)
(NULL (CDR T1))
(EQ (CAAR T1) 'QUOTE))
#(OUTFS 'HRRZ
VALAC
(COND ((CADAR T1) (CAR T1))
('T 'NILPROPS))))
('T (COND ((EQ TEM 'PLUSP)
#(OUTFS 'SKIPN (COND ((= T1 VALAC) 0) (T1)) T1))
((OUT1 'SKIPN VALAC T1)))
#(OUTFS 'SKIPA VALAC 'NILPROPS)
#(OUTFS 'HRRZ VALAC 0 VALAC)
(|Oh, FOO!|)))
(GO RETV))
((EQ X 'CXR)
(SETQ X (COMP1 (CAR Y)) Y (COMP1 (CADR Y)))
(SETQ Z (ILOCMODE Y
(COND ((EQ (CAR X) 'QUOTE) 'ARGNO) ('1))
'(() FIXNUM FLONUM)))
(COND ((AND #(REGACP Z)
(OR (= Z 1) (EQ (CAR X) 'QUOTE)))
(REMOVEB Y)
(CPUSH Z))
('T (SETQ Z (COND ((NOT (EQ (CAR X) 'QUOTE)) 1)
((AND (AND (NOT EFFS)
(NOT #(NUMACP-N ARGNO)))
(COND ((NOT (DVP ARGNO)))
('T (CPUSH1 ARGNO 'CLEARVARS () )
(NOT (DVP1 SLOTX ARGNO)))))
ARGNO)
((FREEREGAC 'FRACB))))
(LOADAC Y Z () )))
(SETQ VALAC Z)
(COND ((EQ (CAR X) 'QUOTE)
(SETQ NARGS (CADR X))
(AND (OR (NOT (FIXP (CADR X)))
(< NARGS 0)
(> NARGS 511.))
(DBARF F |Illegal arg - CXR|))
(REMOVE X)
#(OUTFS (COND ((ODDP NARGS) 'HLRZ) ('HRRZ))
Z
(LSH NARGS -1)
Z))
('T (LOADAC X #(NUMVALAC) () )
(OUTPUT '(JSP T %CXR))
(RPLACA NUMACS () ))) ;(CONT #(NUMVALAC) () )
(GO RETV))
((EQ X 'SFA-CALL)
(LOADACS (ITEML Y () ) 3 () )
#(CLEARALLACS)
(OUTPUT '(MOVEI TT SFCALI))
(OUTPUT '(XCT 0 @ 1 1))
(GO RETV))
((EQ X 'MUNKAM)
(SETQ UNSAFEP 'T
Z (COMP0 (CAR Y))
TEM #(ILOCN Z))
(SETQ VALAC (COND ((NOT #(NUMACP TEM)) TEM)
(#(NOT (NUMACP-N ARGNO)) ARGNO)
((FRAC5))))
(REMOVEB Z)
(COND (#(NUMACP TEM)
((LAMBDA (TAKENAC1) (CPUSH VALAC)) TEM))
((CPUSH VALAC)))
(OUT1 (COND ((REGADP TEM) '(HRRZ)) ('HRRZ)) VALAC TEM)
(GO RETV))
((MEMQ X '(EXAMINE DEPOSIT))
(SETQ VALAC (COND (#(NUMACP-N ARGNO) ARGNO)
('T (FREENUMAC))))
(SETQ T1 (COMPW (CAR Y) () VALAC) TEM () )
(AND (EQ X 'DEPOSIT) (SETQ Y (COMPW (CADR Y) () #(NUMVALAC))))
(SETQ T1 (COND ((AND (NOT (EQ (CAR T1) 'QUOTE))
(SETQ Z (ILOCMODE T1 () 'FIXNUM))
(COND (#(ACLOCP Z) (SETQ TEM (REGADP Z)) 'T)
((NOT (REGADP Z)))))
(REMOVE T1)
Z)
((LOADINNUMAC T1 VALAC () 'REMOVEB))))
(COND ((EQ X 'EXAMINE)
(CPUSH VALAC)
(COND (TEM #(OUTFS 'MOVE VALAC '@ 0 T1))
('T (OUT1 '(MOVE) VALAC T1)))
(SETMODE VALAC 'FIXNUM)
(GO RETV))
('T #(LET ((TAKENAC1 T1)) (SETQ Y (LOADINSOMENUMAC Y)))
(COND (TEM #(OUTFS 'MOVEM Y '@ 0 T1))
('T (OUT1 '(MOVEM) Y T1)))
(RETURN '(QUOTE T))))) ))
((EQ T1 'JSP)
(SETQ JSP (GET X 'JSP)) ;CONS, %HUNKn, etc
(AND (EQ X 'CONS)
(QNILP (CADR Y))
(SETQ X 'NCONS
Y (LIST (CAR Y))
JSP (GET X 'JSP)))
(SETQ T1 '((PNOB PNOB PNOB PNOB PNOB) () PNOB PNOB PNOB PNOB PNOB))
(GO LDARGS))
((MEMQ T1 '(EXPR *EXPR)) ) ;Normal case - Do nothing
((MEMQ T1 '(*LEXPR LSUBR)) ;Compile L-type form
(COND ((EQ X PROGN) (PROG2 (REMOVE (SETQ Z (COMPROGN Y EFFS))) (RETURN Z)))
((EQ X 'PROG2)
(COMPE (CAR Y))
(SETQ T1 (COMP0 (CADR Y)))
(MAPC 'COMPE (CDDR Y))
(REMOVE T1)
(RETURN T1))
((AND (EQ X 'BOOLE) (EQ (CAAR Y) 'QUOTE)) (RETURN (COMBOOLE Y)))
((AND (EQ X 'PRINC)
(NOT (ATOM (CAR Y)))
(EQ (CAAR Y) 'QUOTE)
(STRTIBLE (CADAR Y)))
(GO OUTSTRT)))
(SETQ VALAC (COMLC X Y () ))
(GO CALLX))
((EQ T1 '*FEXPR) #(NO-DELAYED-SPLDS) (GO F-FORM))
('T (GO LOSTF)))) ;*FEXPR should be case left
((SETQ ARRAYP (GET X '*ARRAY))
(COND ((AND ARRAYOPEN (NOT (EQ ARRAYP 'T)))
(SETQ VALAC (COMARRAY X Y ARRAYP () ))
(GO RET))))
((EQ X GOFOO) ;Hac for MAP series
((LAMBDA (AC)
(OUTPUT '(PUSH P (% 0 0 '())))
(PUSH (LIST (CAR Y)) REGPDL)
(OUTPUT (CONS 'MOVEI (CONS AC '(0 P))))
(CONT AC (LIST (CADR Y))))
(FRAC1))
(SETQ OLVRL (DELQ (CAR Y) (DELQ (CADR Y) OLVRL)))
(GO RET))
('T (GO LOSTF) ))
(SETQ T1 (OR (GET X 'NUMFUN) (FUNMODE X)))
LDARGS ;Compile for normal EXPR or SUBR type
(COND ((OR (NULL SPLDLST)
(NULL LDLST)
ARRAYP
JSP
(AND (GET X 'ACS) (NOT (EQ (GET X 'NOTNUMP) 'EFFS)))
(NULL (FLUSH-SPL-NILS)))
(SETQ Z (ITEML Y T1))
(SETQ TEM () )
(COND ((AND (CDR Y) ;Commutative 2-arg function
(NULL (CDDR Y)) ;2nd arg in acc 1, but
(NULL ARRAYP)
(SETQ TEM (GET X 'COMMU)) ; first arg not in ac
(EQUAL (ILOC0 (CAR Z) () ) 1)
(NOT (EQUAL (ILOC0 (CADR Z) () ) 1)))
(SETQ Z (REVERSE Z))
(SETQ X TEM)
(AND JSP (SETQ JSP (GET X 'JSP))))))
('T #(NO-DELAYED-SPLDS) ;Spec var and carcdr loads
(SETQ Z (ITEML Y T1))))
(LOADACS Z (SETQ NARGS (LENGTH Z)) T1)
CALL ;Output a "CALL" to the function
(COND ((NULL JSP)
(CLEARACS1 X () )
(SETQ VALAC (OUTFUNCALL 'CALL NARGS X)))
('T (COND ((NULL (CDR JSP)) (SETQ JSP (CAR JSP))) ;%HUNK3 and %HUNK4 cases
('T (SETQ JSP (COND ((NOT (UNSAFEP (CAR REGACS)))
(CAR JSP)) ;4-way split depending
((CDR JSP)))) ; on safety of args
(COND ((EQ JSP 'PUNT) (SETQ JSP () ) (GO CALL))) ;punt this case, do CALL
(SETQ JSP (COND ((OR (NULL (CDR JSP)) ;dont check 2nd arg on
(NOT (UNSAFEP (CADR REGACS))));1-arg functions
(CAR JSP))
((CDR JSP))))))
(CLEARACS1 X () )
(OUTPUT JSP)))
CALLX (AND CCSLD (DIDUP CLPROGN)) ;Delete IDUPS if CSLD was called
(AND UNSAFEP (BARF () |UNSAFEP after "CALL" - COMPFORM|))
(AND (OR CCSLD
(AND (NOT JSP)
(SYMBOLP X)
(OR (NOT (GET X 'ACS))
(NOT (EQ (GET X 'NOTNUMP) 'NOTNUMP)))))
(CARCDR-FREEZE () () )) ;Freeze carcdrings if unsure
RETV (COND (EFFS (CONT VALAC () ) (RETURN () )))
RET (COND (EFFS (RETURN () ))
('T (SETQ Z (LIST (GENSYM)))
(AND (AND UNSAFEP (NOT #(NUMACP-N VALAC)))
(PUTPROP (CAR Z) 'T 'UNSAFEP))
(CONT VALAC Z)
(RETURN Z)))
RET-NO (SETQ VALAC ARGNO)
(GO RETV)
F-FORM (CPUSH 1)
(OUT1 'MOVEI 1 (LIST 'QUOTE Y))
(CONT 1 () )
F-* (SETQ NARGS 15.) ;15. Indicates F-type CALL
(GO CALL)
OUTSTRT
(SETQ T1 (COND ((NULL (CDR Y)) 0)
((EQ (CAR (SETQ T1 (COMP (CADR Y)))) 'MSGFILES)
(REMOVE T1)
15.)
((LOADINREGAC T1 'FRACB () ))))
#(OUTFS 'STRT T1 (LIST '% 'SIXBIT (6BSTR (CADAR Y))))
(RETURN '(QUOTE T))
LOSTF (BARF X |Lost function - COMPFORM|) ))
(COMMENT PHASE2 COMPILATION FUNCTIONS)
(DEFUN COMABSMINUS (FUN ARG)
((LAMBDA (OP ARG AC TYPE LARG)
(SETQ LARG (ILOCMODE ARG 'FREENUMAC TYPE))
(REMOVE ARG)
(COND ((AND (NOT ATPL)
(EQ (CAR LOUT) 'MOVE)
#(NUMACP LARG)
(NOT (DVP LARG))
(NUMBERP (CADR LOUT))
(= (CADR LOUT) LARG))
(RPLACA LOUT (CAR OP))
(SETQ AC LARG))
('T (COND (#(NUMACP LARG)
(SETQ AC LARG)
(CPUSH LARG)
#(OUTFS (COND ((EQ (CAR OP) 'MOVN) 'MOVNS) ('MOVMS))
0
LARG))
('T (OUT3 OP (SETQ AC (FREENUMAC)) LARG)))))
(SETMODE AC TYPE)
(CAR (CONT AC (LIST (GENSYM)))))
(COND ((EQ FUN 'MINUS) '(MOVN)) ((EQ FUN 'ABS) '(MOVM)))
(COMPW (CADR ARG) () #(NUMVALAC))
0
(CAR ARG)
() ))
(DEFUN COMAD1SB1 (FUN ARG)
((LAMBDA (AC N)
(AND (EQ (CAR ARG) 'FLONUM) (SETQ N (+ N 2)))
(AND (EQ FUN 'SUB1) (SETQ N (1+ N)))
(OUTPUT (A1S1A (- AC #(NUMVALAC)) N))
(SETMODE AC (CAR ARG))
(CAR (CONT AC (LIST (GENSYM)))))
(LOADINSOMENUMAC (COMPW (CADR ARG) () #(NUMVALAC)))
0))
(DEFUN COMARITH (FUN LL)
((LAMBDA (MIXP TYPEL ARGL)
(SETQ TYPEL (COND ((NULL (CAR LL)) (CAR COMAL))
((EQ (CAR LL) 'FIXNUM) (CADR COMAL))
((EQ (CAR LL) 'FLONUM) (CADDR COMAL))
('T (SETQ MIXP (MEMQ '() (CAR LL))) (CAR LL))))
(SETQ ARGL ((LAMBDA (ARGNO EFFS PNOB TEM)
(MAPCAR '(LAMBDA (ARG TYPE)
(COND (TYPE
(FREEIFYNUMAC)
(SETQ ARGNO #(NUMVALAC))
(SETQ ARG (COMP0 ARG))
(AND (NOT (EQ (CAR ARG) 'QUOTE))
(SETQ TEM (ASSQ (CAR ARG) NUMACS))
(NULL (GETMODE0
(- ##(+ #(NUMVALAC) #(NUMNACS))
(LENGTH (MEMQ TEM NUMACS)))
'T
() ))
(NUMODIFY ARG TYPE))
ARG)
('T (SETQ ARGNO 1)
(COMP0 ARG))))
(CDR LL)
TYPEL))
#(NUMVALAC) () () () ))
(COND ((OR (EQ TYPEL (CAR COMAL)) MIXP)
(CAR (CONT (COMLC FUN ARGL 'T) (LIST (GENSYM)))))
((PROG (ARG1 ARG2 OP AC AD MODE)
(SETQ AC 0 MODE (CAR TYPEL))
(SETQ OP (CDR (ASSQ FUN (COND ((EQ MODE 'FIXNUM)
'((PLUS ADD) (DIFFERENCE SUB)
(TIMES IMUL) (QUOTIENT IDIV)))
('T '((PLUS FADR) (DIFFERENCE FSBR)
(TIMES FMPR) (QUOTIENT FDVR)))))))
(REMOVE (SETQ ARG1 (CAR ARGL)))
A (AND (NULL (SETQ ARGL (CDR ARGL))) (RETURN ARG1))
(COND ((CDR TYPEL) (SETQ TYPEL (CDR TYPEL))))
(SETQ ARG2 (CAR ARGL))
(COND ((NOT (EQ MODE (CAR TYPEL)))
(COND ((EQ MODE 'FIXNUM)
(SETQ ARG1 (COMFIXFLT ARG1 (SETQ MODE 'FLONUM)))
(SETQ OP (CDR (ASSQ (CAR OP) '((ADD FADR) (SUB FSBR)
(IMUL FMPR) (IDIV FDVR))))))
('T (PUSH ARG1 LDLST)
(PUSH (SETQ ARG2 (COMFIXFLT ARG2 'FLONUM)) LDLST)))))
(COND ((AND (MEMQ FUN '(PLUS TIMES))
(NOT #(ACLOCP (ILOC0 ARG1 MODE)))
#(ACLOCP (SETQ AD (ILOC0 ARG2 MODE))))
(REMOVEB ARG2)
(CPUSH (SETQ ARG2 ARG1 AC AD)))
((EQ (CAR OP) 'IDIV)
(SETQ AD ((LAMBDA (TAKENAC1) (FREENUMAC))
##(+ (NUMVALAC) (NUMNACS) -1)))
(SETQ AC (LOADINNUMAC ARG1 AD () 'REMOVEB))
(COND ((= AC ##(+ (NUMVALAC) (NUMNACS) -1))
(LOADAC ARG1 AD () )
(CONT AC () )
(SETQ AC AD))))
('T (SETQ AC (LOADINSOMENUMAC ARG1))))
(COND ((AND (EQ FUN 'TIMES) ;TRAP FOR MUL BY POWER OF 2
(EQ MODE 'FIXNUM)
(QNP ARG2)
#(/2↑N-P (CADR ARG2)))
(REMOVE ARG2)
(COND ((> (CADR ARG2) 1)
#(OUTFS 'ASH AC (1- (HAULONG (CADR ARG2)))))
((= (CADR ARG2) 0) #(OUTFS 'MOVEI AC 0)))
(GO B)))
(SETQ AD ((LAMBDA (TAKENAC1) #(ILOCNUM ARG2 'FREENUMAC)) AC))
(REMOVEB ARG2)
(COND ((EQ (CAR OP) 'IDIV)
((LAMBDA (II)
(AND (CPUSH-DDLPDLP II AD) ;LEAVES SLOTX SET AT II
(SETQ AD (1- AD)))
(RPLACA SLOTX () )
(SETMODE AC () ))
(1+ AC)))
((AND #(ACLOCP AD) (= AD ##(NUMVALAC)) (MEMQ FUN '(PLUS TIMES)))
(SETQ AD AC AC ##(NUMVALAC))))
(AND (CPUSH-DDLPDLP AC AD) (SETQ AD (1- AD)))
(OUT3 OP AC AD)
B (SETMODE AC MODE)
(SETQ ARG1 (CAR (CONT AC (LIST (GENSYM)))))
(GO A)))))
() () () ))
(DEFUN COMARRAY (X Y FORM MODE)
(SETQ Y (NREVERSE
(ITEML Y (COND ((AND FORM (SETQ Y (GET X 'NUMFUN))) (SETQ MODE (CADR Y)) Y)
(#(NCDR '(FIXNUM FIXNUM FIXNUM FIXNUM FIXNUM FIXNUM FIXNUM)
(- 5 (LENGTH Y))))))))
(COM-AREF X Y () MODE FORM))
;COMPILE FOR ARRAY REFERENCES
(DEFUN COM-AREF (X Y STORE MODE FORM)
(PROG (LOC ADDR ACX SVSLT FLAG TAKENAC1 ACLQ PARITY II)
(DECLARE (FIXNUM PARITY))
(SETQ TAKENAC1 0 PARITY 0)
(SETQ LOC (COND ((AND (NOT EFFS) (NOT #(NUMACP-N ARGNO))) ARGNO)
(STORE (FRAC1))
((FRAC5))))
(COND ((AND (NULL MODE) STORE)
(SETQ ADDR #(ILOCREG STORE LOC))
(REMOVS STORE)
(SETQ STORE (MAKESAFE STORE ADDR () ))))
(SETQ ADDR
(CONS '@
(COND ((NULL FORM) ;FORM=() => "ARRAYCALL" TYPE
(SETQ ACLQ (LIST (GENSYM))
ACX (COND ((OR MODE (NOT STORE))
(LOADINREGAC X
LOC
(ILOCMODE X LOC () )))
((LOADINREGAC X () () )))
SVSLT (FIND ACX))
(RPLACA SVSLT ACLQ)
(PUSH ACLQ LDLST)
(LIST 1 ACX))
('T (SETQ FORM (COND ((EQ FORM 'T) () )
((CDR FORM))))
(LIST (LIST 'ARRAY X))))))
(COND ((NULL (CDR Y))
(COND ((AND STORE
MODE
(NOT (EQ (CAR STORE) 'QUOTE))
(SETQ FLAG (ILOC2 (VARBP (CAR STORE)) STORE MODE))
(NUMBERP FLAG)
(= FLAG #(NUMVALAC))
(NOT (ZEROP (FREENUMAC1))))
(SETQ TAKENAC1 #(NUMVALAC)
FLAG (LOADINSOMENUMAC (CAR Y))
TAKENAC1 0)
(OUT1 'EXCH FLAG #(NUMVALAC))
(CONT FLAG (CAR NUMACS))
(SETMODE FLAG (CAR ACSMODE))
(RPLACA NUMACS (SETQ FLAG () ))) ;(CONT #(NUMVALAC) () )
((QNP (CAR Y)) (REMOVE (CAR Y)) (SETQ FLAG (CADAR Y)))
('T (LOADAC (CAR Y) #(NUMVALAC) (SETQ FLAG () )))))
('T (PROG (N D)
(SETQ N 0 TAKENAC1 #(NUMVALAC))
(COND ((AND FORM
(DO ((ZZ FORM (CDR ZZ)) (Z Y (CDR Z)))
((NULL Z) (SETQ FLAG 'T))
(COND ((AND (QNP (CAR Z))
(FIXP (SETQ ACX (CADAR Z)))
(COND ((FIXP (SETQ D (CAR ZZ))))
((EQ Y Z) (SETQ D 0) 'T)))
(SETQ N (+ (* D N) ACX))) ;Dimensionality and particular index
((EQ Y Z) (RETURN () )) ;combined when both are constant
('T (MAPC 'REMOVE (LSUB Y Z))
(COND ((FIXP (CAR ZZ))
(SETQ N (* N (CAR ZZ))
FORM (CONS () (CONS CLPROGN (CDR ZZ)))
Y (CONS () Z)))
('T (SETQ Y (CONS (LIST 'QUOTE N) Z)
FORM (CONS () ZZ))))
(SETQ FLAG () )
(RETURN 'T)))))
(SETQ PARITY (COND ((ODDP N) -1) (1)))
(COND (FLAG (MAPC 'REMOVE Y) ;Here, FLAG=T signals
(SETQ FLAG N) ;a constant linearized index
(RETURN () ))
((AND (NULL (CAR Y)) (NULL (CDDR Y)))
(SETQ PARITY 0) ;PARITY has been lost here
(LOADAC (CADR Y) #(NUMVALAC) () )
(AND (NOT (ZEROP N)) ;Note that FLAG = ()
#(OUTFS 'ADDI #(NUMVALAC) N))
(RETURN () ))
('T (CPUSH #(NUMVALAC))
(SETQ TAKENAC1 (SETQ ACX (FREENUMAC)))
#(OUTFS 'MOVEI ACX N))))
('T (SETQ FLAG 'T)))
(SETQ N (1- (LENGTH Y)))
;At this point, FLAG=() signals a partial index calcualtion has been done
(COND ((NULL FLAG))
('T (SETQ ACX (LOADINSOMENUMAC (CAR Y)))
(AND (NOT (= ACX #(NUMVALAC))) (CPUSH #(NUMVALAC)))
(CONT ACX () )
(SETQ TAKENAC1 ACX)))
A (COND ((AND FORM (SETQ FORM (CDR FORM)) (FIXP (CAR FORM)))
(SETQ II (CAR FORM))
(AND (NOT MODE) (NOT (ODDP II)) (SETQ PARITY 1))
(COND (#(/2↑N-P II) #(OUTFS 'ASH ACX (1- (HAULONG II))))
('T (OUT2 '(IMUL) ACX (LIST (LIST 'QUOTE (CAR FORM)))))))
((OR (NULL FORM) (NOT (EQ (CAR FORM) CLPROGN)))
(AND (NOT MODE) (MINUSP PARITY) (SETQ PARITY 0))
(COND ((= ACX #(NUMVALAC))
(SETQ ACX (FREENUMAC))
(RPLACA SLOTX () ) ;FREENUMAC LEAVES SLOTX AT AC SLOT
#(OUTFS 'MOVEI ACX 0 #(NUMVALAC))
(SETQ TAKENAC1 ACX)))
(OUTPUT (BOLA N 4)) ;"(MOVNI 7 N)"
(RPLACA NUMACS () ) ;(CONT #(NUMVALAC) () )
(AND ACLQ (NOT (EQ ACLQ (CAR SVSLT)))
(SETQ ADDR (ACLQ-FIND ACLQ () )
SVSLT (FIND (CADDR ADDR))))
(OUTPUT (CONS 'IMUL (CONS ACX ADDR)))))
(COND ((CDR (SETQ Y (CDR Y)))
(COND (MODE)
((QNP (CAR Y))
(AND (ODDP (SETQ II (CADAR Y))) (SETQ PARITY (- PARITY))))
('T (SETQ PARITY 0)))
(AREF-ADD (CAR Y) ACX) ;"(ADD ACX LOC[(CAR Y)])"
(SETQ N (1- N))
(GO A))
('T (COND ((QNP (CAR Y))
(AND (NOT MODE) (ODDP (SETQ II (CADAR Y))) (SETQ PARITY (- PARITY)))
(REMOVE (CAR Y))
#(OUTFS 'MOVEI #(NUMVALAC) (CADAR Y) ACX))
((PROG2 (SETQ PARITY 0) (= ACX #(NUMVALAC)))
(AREF-ADD (CAR Y) ACX))
('T (LOADAC (CAR Y) #(NUMVALAC) () )
#(OUTFS 'ADD #(NUMVALAC) ACX)))
(CONT ACX () )
(RETURN (SETQ FLAG () )) ))) ;Normal exit leaves FLAG = ()
(SETQ TAKENAC1 0)))
(COND (FLAG (COND ((AND MODE STORE
(NUMBERP (SETQ LOC (ILOC0 STORE MODE)))
(= LOC ##(NUMVALAC)))
(SETQ LOC ((LAMBDA (TAKENAC1) (FREENUMAC))
#(NUMVALAC)))
(LOADAC STORE LOC () ))) ;Non-null FLAG indicates constant
(CLEARACS -1 'T () ))
('T (PUSH (SETQ FORM (LIST (GENSYM))) LDLST) ;INDEX not yet loaded; null FLAG
(RPLACA NUMACS FORM) ;Means computed index in NUMVALAC
(RPLACA ACSMODE 'FIXNUM)))
(AND MODE (GO NUMARRAY))
SARRAY
(SETQ ACX 'T) ;FLAG on whether or not to look up ACLQ again
(SETQ LOC (COND (STORE (LOADINREGAC STORE () (ILOC0 STORE () )))
((AND (NOT EFFS) (NOT #(NUMACP-N ARGNO)))
(SETQ ACX () )
(AND ACLQ (REMOVE ACLQ))
(CPUSH ARGNO)
ARGNO)
('T (FRAC5))))
(AND ACLQ ACX (NOT (EQ ACLQ (CAR SVSLT)))
(SETQ ADDR (ACLQ-FIND ACLQ LOC)
SVSLT (FIND (CADDR ADDR))))
(SETQ ADDR (CONS LOC ADDR))
(COND (FLAG #(OUTFS 'MOVEI #(NUMVALAC) (LSH FLAG -1))
(OUTPUT (CONS (COND ((ODDP (SETQ II FLAG)) (COND (STORE 'HRRM) ('HRRZ)))
('T (COND (STORE 'HRLM) ('HLRZ))))
ADDR)))
('T (REMOVE FORM)
(COND ((ZEROP PARITY)
(OUTPUT ##(SUBST (NUMVALAC) 'AC ''(ROT AC -1)))
(OUTPUT ##(SUBST (NUMVALAC) 'AC ''(JUMPL AC (* 3))))
(OUTPUT (CONS (COND (STORE 'HRLM) ('HLRZ)) ADDR))
(OUTPUT '(JUMPA 0 (* 2)))
(OUTPUT (CONS (COND (STORE 'HRRM) ('HRRZ)) ADDR))
(|Oh, FOO!|))
('T (COND ((OR ATPL ATPL1
(NOT (EQ (CAR LOUT) 'MOVEI))
(COND ((EQ (CAR LOUT1) 'ASH) () )
((EQ (CAR LOUT1) 'IMULI) (ODDP (CADDR LOUT1))))
(NOT (= (CADDDR LOUT) (CADR LOUT1))))
(OUTPUT ##(SUBST (NUMVALAC) 'AC ''(ROT AC -1))))
('T (RPLACA (CDDR LOUT1)
(COND ((EQ (CAR LOUT1) 'ASH) (1- (CADDR LOUT1)))
('T (// (CADDR LOUT1) 2))))
(RPLACA (CDDR LOUT) (// (CADDR LOUT) 2))))
(OUTPUT (COND ((PLUSP PARITY) (CONS (COND (STORE 'HRLM) ('HLRZ)) ADDR))
((CONS (COND (STORE 'HRRM) ('HRRZ)) ADDR))))))))
(GO END)
NUMARRAY
(COND (FLAG #(OUTFS 'MOVEI #(NUMVALAC) FLAG)))
(SETQ LOC (COND (STORE ((LAMBDA (TAKENAC1) (LOADINSOMENUMAC STORE))
#(NUMVALAC)))
('T (COND (#(NUMACP-N ARGNO) ARGNO) (#(NUMVALAC))))))
(AND ACLQ (NOT (EQ ACLQ (CAR SVSLT)))
(SETQ ADDR (ACLQ-FIND ACLQ () )
SVSLT (FIND (CADDR ADDR))))
(OUTPUT (CONS (COND (STORE 'MOVEM) ('MOVE)) (CONS LOC ADDR)))
(SETMODE LOC MODE)
(AND (NULL FLAG) (REMOVE FORM))
END
(COND (ACLQ (RPLACA SVSLT () ) (REMOVE ACLQ)))
(RETURN LOC)))
(DEFUN ACLQ-FIND (ACLQ LOC) ;Called only by COM-AREF
((LAMBDA (ACX)
(COND (#(REGACP ACX))
((NULL LOC) (LOADAC ACLQ (SETQ ACX (FRAC5)) () ))
(((LAMBDA (SVSLT)
(SETQ LOC (CAR SVSLT))
(RPLACA SVSLT '(NIL . TAKEN))
(LOADAC ACLQ (SETQ ACX (FRAC5)) () )
(RPLACA SVSLT LOC))
(FIND LOC))))
(LIST '@ 1 ACX))
(ILOC0 ACLQ () )))
(DEFUN AREF-ADD (ITEM ACX) ;COM-AREF "ADD"
(OUT3 '(ADD) ACX (ILOCMODE ITEM 'FREENUMAC 'FIXNUM))
(REMOVE ITEM))
(DEFUN COMBOOLE (ARGL)
((LAMBDA (N ARGNO EFFS Y)
(SETQ Y (CAR ARGL))
(AND (OR (NOT (FIXP (CADR Y))) (< (SETQ N (CADR Y)) 0) (> N 15.))
(BARF ARGL |Inconstant type - COMBOOLE|))
(SETQ ARGL (MAPCAR 'COMP0 (CDR ARGL)))
((LAMBDA (AC ARG1 AD)
(COND ((OR (= N 3) (= N 5) (= N 10.) (= N 12.) (= N 0) (= N 15.))
(COND ((OR (= N 0) (= N 15.))
(SETQ AC (FREENUMAC))
#(OUTFS (CAR (CBA N)) AC AC))
('T (COND ((OR (= N 3) (= N 12.))
(SETQ ARG1 (CAR (LAST ARGL)))))
(SETQ AC (LOADINSOMENUMAC ARG1))
(COND ((OR (= N 10.) (= N 12.))
(COND ((AND (NOT ATPL) (NOT (EQ (CAR LOUT) 'MOVE)))
(RPLACA LOUT (CAR (CBA 10.))))
('T (OUTPUT (LIST (CAR (CBA 12.))
AC))))))))
(MAPC 'REMOVEB ARGL)
(SETMODE AC 'FIXNUM))
((NULL (CDR ARGL))
#(WARN (CONS Y ARGL) |Too few args to BOOLE - COMBOOLE|)
(REMOVEB ARG1)
ARG1)
((DO ((ARGL (CDR ARGL) (CDR ARGL))) ((NULL ARGL) ARG1)
(COND ((AND (NOT #(ACLOCP (ILOC0 ARG1 'FIXNUM)))
#(ACLOCP (SETQ AD (ILOC0 (CAR ARGL) 'FIXNUM))))
(REMOVEB (CAR ARGL))
(CPUSH AD)
(SETQ AC AD
AD ((LAMBDA (TAKENAC1) #(ILOCNUM ARG1 'FREENUMAC)) AC))
(COND ((OR (= N 2) (= N 13)) (SETQ N (+ N 2)))
((OR (= N 4) (= N 15)) (SETQ N (- N 2))))
(REMOVEB ARG1))
('T (SETQ AC (LOADINSOMENUMAC ARG1))
((LAMBDA (TAKENAC1) (SETQ AD #(ILOCNUM (CAR ARGL) 'FREENUMAC))) AC)
(REMOVEB (CAR ARGL))))
(COND ((AND (NOT ATPL) (EQ (CAR LOUT) 'MOVE) (EQUAL (CADR LOUT) AD))
(CONT AD () )
(SETQ LOUT (CONS (CAR (CBA N)) (CONS AC (CDDR LOUT)))))
('T (OUT3 (CBA N) AC AD)))
(COND ((CDR ARGL) ;Prepare for next
(PUSH (SETQ ARG1 (LIST (GENSYM))) LDLST) ;time around loop
(CONT AC ARG1)))
(SETMODE AC 'FIXNUM))))
(CAR (CONT AC (LIST (GENSYM)))))
0 (CAR ARGL) () ))
0 #(NUMVALAC) () () ))
(DEFUN COMCOND (Y BTEST F C@LCP)
; typical y = (complexity setqlist condunsf mod clause 1 - - clause n)
(AND (AND C@LCP (NOT (GET C@LCP 'LEVEL))) ;PROG tag - make sure that the
(CPVRL)) ; PRSSL has been set
(CLEAR (CADR Y) 'T)
((LAMBDA (CEXIT EXLDL CLZTAG SVSPLDLST TEM ACX LASTCLZP JSP SNILP PNOB CONDPNOB)
(COND ((AND (NOT EFFS) ;A COND for value which is
(NOT BTEST) ; complex enough to warrant
(NOT (= ARGNO 1)) ; switching the valac to 1
(> (CAR Y) 1)
(NOT #(NUMACP-N ARGNO)))
(SETQ ARGNO 1)))
(DO EXP (CDDDDR Y) (CDR EXP) (NULL EXP)
(SETQ SNILP 'T)
(SETQ LASTCLZP (NULL (CDR EXP)))
(COND ((OR (NULL (CDAR EXP)) (EQ (CADAR EXP) NULFU))
; COND pair with only one part
; or like ((NULL EXP) () ) for value
; expressed as (EXP NULFU)
(COND (BTEST
(COND ((OR F LASTCLZP (CDAR EXP))
(BOOL1LCK (CAAR EXP) BTEST F))
('T (BOOL1LCK (CAAR EXP) CEXIT 'T)))
(CLEARVARS))
(EFFS (COND (LASTCLZP (COMPE (CAAR EXP)))
((BOOL1LCK (CAAR EXP) CEXIT (NULL (CDAR EXP)))))
(CLEARVARS))
((AND (NOT LASTCLZP) (NULL (CDAR EXP))
#(NUMACP-N ARGNO))
(SETQ CLZTAG (LEVELTAG))
(SETQ TEM (COMPR (CAAR EXP) () 'T 'T))
(BOOL3 TEM () CLZTAG () )
(LOADINSOMENUMAC TEM)
(CLEARVARS)
(OJRST CEXIT () )
(OUTTAG-TO-LEVEL CLZTAG))
('T ((LAMBDA (PNOB) (LOADAC (COMP (CAAR EXP))
ARGNO
(NOT CONDPNOB)))
CONDPNOB)
(CLEARVARS)
(AND (NOT LASTCLZP)
(COND ((OR #(NUMACP-N ARGNO)
(AND (NOT ATPL)
(EQ (CAR LOUT) 'JSP)
(MEMQ (CADDR LOUT) '(FXCONS FLCONS))))
(OJRST CEXIT () ))
('T
(COND ((SETQ TEM (BADTAGP CEXIT))
(SETQ TEM (LEVELTAG))
(OUTJ (COND ((CDAR EXP) 'JUMPN)
('JUMPE))
ARGNO
TEM)
(OJRST CEXIT () )
(OUTTAG-TO-LEVEL TEM))
((OUTJ (COND ((CDAR EXP) 'JUMPE)
('JUMPN))
ARGNO
CEXIT)))))))))
((AND (SETQ TEM (NULL (CDDAR EXP)))
(EQ (CAADAR EXP) 'GO)
(ATOM (CADADR (CAR EXP)))
(EASYGO))
; Like "(EXP (GO FOO))"
(SETQ SNILP (BOOL1 (CAAR EXP) (ADR (CADADR (CAR EXP))) 'T)))
((AND TEM
(EQ (CAADAR EXP) 'RETURN)
(QNILP (CADR (CADAR EXP)))
(EASYGO))
; Like "(EXP (RETURN () ))"
(SETQ SNILP (BOOL1 (CAAR EXP) (GENTAG 'EXITN) 'T)))
((AND (NOT EFFS) ;(COND . . .
(NOT BTEST) ; ((FOO BAR) . . . X)
(COND ((NULL (CDR EXP)) ; (T Y))
(SETQ TEM ''()) ;OR LATTER CLAUSE MIGHT SIMPLY BE
(OR (ATOM (CAAR EXP)) ; (Y), OR BE ABSENT [EG, (T () )]
(P1BOOL1ABLE (CAAR EXP))))
((NULL (CDDR EXP)) ;X MUST BE VAR, OR QUOTED
(SETQ TEM ;Y MUST BE 1INSP
(COND ((NULL (CDR (SETQ TEM (CADR EXP))))
(CAR TEM))
((AND (NULL (CDDR TEM))
(EQ (CAAR TEM) 'QUOTE)
(CADR TEM))
(CADR TEM)))) ;X HELD BY JSP, Y BY TEM
(COND ((NULL TEM) () )
((ATOM TEM) (1INSP TEM))
((MEMQ (CAR TEM) '(QUOTE FUNCTION)))
(#(NUMACP-N ARGNO) () )
((AND (NOT (ATOM (CAR TEM)))
(EQ (CAAR TEM) CARCDR)
(NULL (CDDAR TEM))
(ATOM (CADR TEM)))))))
(PROG2 (SETQ SVSPLDLST (CDDAR EXP) ACX () ) 'T)
(COND ((ATOM (SETQ JSP (CAR (LAST (CAR EXP)))))
(COND ((NULL (SETQ ACX (1INSP JSP))) () )
((NOT (EQ ACX CLPROGN))
(SETQ ACX () )
'T)
('T (SETQ ACX 'T)
(AND (NULL SVSPLDLST)
(COND ((ATOM TEM) (NOT (VARMODE TEM)))
((QNILP TEM)))))))
((EQ (CAR JSP) 'QUOTE)
(AND (NULL SVSPLDLST)
(COND ((SYMBOLP TEM)
(OR #(NUMACP-N ARGNO)
(NOT (VARMODE TEM))))
((QNILP TEM)))
(SETQ ACX 'T))
'T)))
(AND ACX (SETQ ACX TEM TEM JSP JSP ACX ACX 'T));ACX=T => INVERTED TEST
(SETQ CLZTAG () )
(CPUSH ARGNO)
(COND ((AND (NULL SVSPLDLST)
(COND ((ATOM (CAAR EXP))
(SETQ SVSPLDLST (CAAR EXP))
'T)
((AND (EQ (CAAAR EXP) 'NULL)
(ATOM (CADAAR EXP)))
(SETQ ACX (NULL ACX) SVSPLDLST (CADAAR EXP))
'T)))
(REMOVE (SETQ SVSPLDLST (COMP0 SVSPLDLST)))
(OUT1 (COND (ACX 'SKIPN) ('SKIPE))
0
#(ILOCN SVSPLDLST)))
((COND (SVSPLDLST () )
((CCHAK-BOOL1ABLE (CAAR EXP) ACX))
((AND (EQ (CAAAR EXP) 'NULL)
(CCHAK-BOOL1ABLE (CADAAR EXP) (NULL ACX))))))
('T (SETQ CLZTAG (LEVELTAG))
(BOOL1 (CAAR EXP) CLZTAG ACX)
(AND (CDDAR EXP)
(MAPC 'COMPE (CDR (L2F (CDAR EXP)))))
(CLEARVARS)
(RST CLZTAG)))
(REMOVE (SETQ JSP (COMP0 JSP)))
(SETQ JSP (ILOCMODE JSP
ARGNO
(COND (#(NUMACP-N ARGNO) '(FIXNUM FLONUM))
('(() FIXNUM FLONUM)))))
(COND ((OR (AND (SETQ ACX (NUMBERP JSP)) (= ARGNO JSP))
(AND (NULL ACX)
(NULL (CDR JSP))
(EQUAL (CAR JSP) (CONTENTS ARGNO))))
(COND ((AND (NOT CLZTAG)
(NOT ATPL)
(SETQ ACX (GET (CAR LOUT) 'CONV)))
(RPLACA LOUT ACX))
((OUTPUT '(SKIPA)))))
((NOT #(NUMACP-N ARGNO))
(COND ((AND (NOT ACX) (QNILP (CAR JSP)))
(OUTPUT (BOLA ARGNO 1)))
('T (OUT1 'SKIPA ARGNO JSP))))
((AND (NOT ACX) (NULL (CDR JSP)) (Q0P+0P (CAR JSP)))
#(OUTFS 'TDZA ARGNO ARGNO))
('T (OUT3 '(SKIPA) ARGNO JSP)))
(COND (CLZTAG (OUTPUT CLZTAG)
(SETQ SVSPLDLST (LIST REGACS NUMACS ACSMODE))
(SLOTLISTSET (LEVEL CLZTAG))))
(REMOVE (SETQ TEM (COMP0 TEM)))
(COND (#(NUMACP-N ARGNO)
(OUT3 '(MOVE) ARGNO #(ILOCNUM TEM ARGNO)))
((PROG2 (SETQ JSP LOUT ACX #(ILOCREG TEM ARGNO))
(COND ((NOT (NUMBERP ACX)) (SETQ JSP 'T))
((NOT (= ACX ARGNO))
(SETQ JSP () )
(AND (REGADP ACX) (SETQ JSP 'T))
'T)))
(OUT1 (COND (JSP 'MOVE)
('T (AND #(NUMACP ACX)
(OR (NOT (EQ (CDR (CONTENTS ACX)) 'DUP))
(PROG2 (CONT ACX () )
()
(SETQ ACX #(ILOCNUM TEM () )))
(NOT #(PDLLOCP ACX)))
(BARF TEM |Lost skip hac - CCMOD|))
'MOVEI))
ARGNO
ACX))
((NOT (EQ JSP LOUT)))
('T ((LAMBDA (INST)
(COND ((OR (COND (CLZTAG ATPL1) (ATPL))
(NOT (MEMQ (CAR INST) '(TDZA SKIPA))))
(BARF INST |Sussman loses - CCMOD|))
((EQ (CAR INST) 'TDZA)
(SETQ INST (CONS 'SETZM (CONS '0 (CDDR INST)))))
('T (SETQ INST (CONS 'MOVE (CDR INST)))))
(COND (CLZTAG (SETQ LOUT1 INST))
('T (SETQ LOUT INST))))
(COND (CLZTAG LOUT1) (LOUT)))))
(|Oh, FOO!|)
(AND CLZTAG (ACSMRGL SVSPLDLST))
(SETQ SNILP 'T)
(AND (CDR EXP) (SETQ EXP (CDR EXP))))
('T (SETQ CLZTAG (LEVELTAG))
(COND ((AND BTEST (NULL F) LASTCLZP)
(BOOL1LCK (CAAR EXP) BTEST () ))
((AND EFFS LASTCLZP)
(BOOL1LCK (CAAR EXP) CEXIT () ))
((BOOL1 (CAAR EXP) CLZTAG () )))
(SETQ SVSPLDLST (APPEND (FLUSH-SPL-NILS) () ))
(SETQ ACX () )
(COMPROGN (CDR (SETQ TEM (L2F (CDAR EXP)))) 'T)
(COND ((EQ (CAAR TEM) 'COND)
(RST CEXIT)
((LAMBDA (PNOB)
(COMCOND (CDAR TEM) BTEST F CEXIT))
CONDPNOB))
(BTEST (BOOL1 (CAR TEM) BTEST F))
(EFFS (COMPE (CAR TEM)))
('T (SETQ ACX ARGNO)
(SETQ TEM ((LAMBDA (PNOB) (COMP0 (CAR TEM)))
CONDPNOB))
(COND ((OR (NOT (QNILP TEM))
(AND (NOT (QNILP (CONTENTS ACX)))
(COND ((NOT LASTCLZP))
((SETQ SNILP () )))))
(LOADAC TEM ACX (NOT CONDPNOB)))
((REMOVEB TEM)))))
(COND ((NOT (SETQ JSP (AND (NOT ATPL) (EQ (CAR LOUT) 'JRST))))
(CLEARVARS)
(COND ((OR (NOT LASTCLZP)
(AND SNILP
(NOT EFFS)
(NOT BTEST)
(GET CLZTAG 'USED)
(SNILPTST CLZTAG)))
(SETQ SNILP () )
(OJRST CEXIT ACX))
('T (RST CEXIT)))))
(|Oh, FOO!|)
(SETQ SPLDLST SVSPLDLST)
(SETQ TEM (COND ((COND ((NOT LASTCLZP))
((GET CLZTAG 'USED)
(AND SNILP
(NOT EFFS)
(NOT BTEST)
(SNILPTST CLZTAG)
(SETQ SNILP () ))
'T))
(OUTTAG0 CLZTAG)
(LEVEL CLZTAG))
((AND (NOT C@LCP) (GET CEXIT 'USED))
(COND ((NOT (EQ (SETQ TEM (LEVEL CEXIT)) PRSSL)) TEM)
((MAPCAR '(LAMBDA (X) (APPEND X () )) TEM))))))
(COND ((NULL TEM))
((AND LASTCLZP (NOT JSP) (NOT C@LCP))
(ACSMRGL TEM))
('T (SLOTLISTSET TEM))))))
(COND (BTEST (COND ((AND (NOT F) (NOT SNILP)) (OJRST BTEST () ))))
((AND (NOT EFFS) (NOT SNILP)) (OUT1 'MOVEI ARGNO '(QUOTE () ))))
(SETQ CNT (PLUS CNT 2))
(COND (C@LCP)
((OUTTAG CEXIT))
('T (CLEARVARS) (RST CEXIT)))
(DIDUP (CADR Y)))
(COND (C@LCP) ((LEVELTAG)))
LDLST
() () () () () () () () PNOB))
(DEFUN SNILPTST (CLZTAG)
(NOT ((LAMBDA (REGACS) (QNILP (CONTENTS ARGNO))) (CAR (LEVEL CLZTAG)))))
(DEFUN CCHAK-BOOL1ABLE (EXP ACX)
(AND (P1BASICBOOL1ABLE EXP)
(NOT (MEMQ (CAR EXP) '(SIGNP NULL PROG2)))
((LAMBDA (PROP)
(COND ((NOT (AND (EQ PROP 'NUMBERP)
(MEMQ (CAR EXP) '(GREATERP LESSP)) ;LIMIT GREATERP AND
(AND (CDDDR EXP) (NULL (CDDDDR EXP))))) ; LESSP TO TWO ARGS
(COND ((MEMQ (CAR EXP) '(EQ EQUAL))
(COMEQ (CDR EXP) () ACX))
((MEMQ (CAR EXP) '(GREATERP LESSP))
(COMGRTLSP EXP () ACX))
((MEMQ (CAR EXP) '(ZEROP PLUSP MINUSP ODDP))
(COMZP EXP () ACX))
((MEMQ PROP '(T NUMBEREP))
(BARF EXP |Lost in CCHAK-BOOL1ABLE|))
('T (COMTP EXP PROP () ACX () )))
'T)))
(GET (CAR EXP) 'P1BOOL1ABLE))))
(DEFUN COMEQ (EXP TAG F)
; Compile EQ. JRST to TAG (or SKIP one instruction) when sense is normal
; (normal sense signalled by non-null F)
; Return non-null iff JUMP to TAG is being outputted by COMEQ
(PROG (X Y Y/' LX LY AC TYPEL TYPX TYPY TEMP N)
(SETQ N 1)
(SETQ TYPEL (SETQ TYPY (SETQ TYPX (POP EXP))))
(COND (TYPEL
(AND (NOT (MEMQ TYPEL '(FIXNUM FLONUM)))
(SETQ TYPX (CAR TYPEL) TYPY (CADR TYPEL)))
(SETQ TEMP (OR (AND (EQ TYPX 'FIXNUM)
(OR (Q0P+0P (SETQ X (CAR EXP)))
(Q1P+1P-1P X)))
(AND (EQ TYPY 'FIXNUM)
(OR (Q0P+0P (SETQ Y (CADR EXP)))
(Q1P+1P-1P Y)))))))
(COND ((AND TEMP TAG)
(AND (NOT Y) (SETQ X (CADR EXP)))
(SETQ AC (LOADINSOMENUMAC (COMPW X () #(NUMVALAC))))
(AND (NOT (= TEMP 0)) (SETMODE AC () ) (CONT AC () ))
(OUTJ (COND ((= TEMP 0) (COND (F 'JUMPE) ('JUMPN)))
((< TEMP 0) (COND (F 'AOJE) ('AOJN)))
('T (COND (F 'SOJE) ('SOJN))))
AC
TAG)
(RETURN 'T)))
(NUMODIFY (SETQ X (COMPW (CAR EXP) () (COND (TYPX #(NUMVALAC)) (1)))) TYPX )
(SETQ Y (COMPW (CADR EXP) () (COND (TYPY (FREENUMAC))
((AND (NULL TYPX)
(NOT EFFS)
(EQUAL 1 (ILOC0 X () )))
ARGNO)
(1))))
; Possibly LY = 1 but Y = (SPECIAL FOO) or (QUOTE FOO)
; will cause LX to become 1
(SETQ LY (ILOCMODE Y (COND (TYPY 'FREENUMAC) ('FRACF)) TYPY))
(SETQ LX (ILOCMODE X (COND (TYPX 'FREENUMAC) ('FRACF)) TYPX))
(COND ((OR (AND TYPEL (NOT (ATOM X)) (EQ (CAR X) 'QUOTE)
(NUMBERP (CADR X)))
(AND TYPY (NOT TYPX)))
(SETQ TEMP X X Y Y TEMP)
(SETQ TEMP LX LX LY LY TEMP)
(SETQ TEMP TYPX TYPX TYPY TYPY TEMP)))
(COND ((AND #(ACLOCP LX) (NOT (AND TYPX (REGADP LX))))
(SETQ AC LX)
(AND (NUMBERP LY)
(= LY 1)
(NOT (EQUAL Y (CAR REGACS)))
(SETQ LY (ILOC0 Y () )))
(SETQ Y/' Y)
(REMOVE X))
((AND #(ACLOCP LY) (NOT (AND TYPY (REGADP LY))))
(SETQ AC LY LY LX Y/' X X Y TEMP TYPX TYPX TYPY TYPY TEMP)
(REMOVE X))
('T (SETQ AC (COND ((NOT TYPX)
(COND ((NOT (DVP1 REGACS 1))
(LOADAC X 1 () ) 1)
('T (LOADINREGAC X () LX))))
((LOADINSOMENUMAC X))))
(SETQ Y/' Y)))
; At this point
; AC contains loc of one arg
; X is internal form of that arg
; LY has loc of other
; Y/' is internal form of arg in LY
(COND (TAG (CLEARVARS)
(COND ((AND #(PDLLOCP LY)
(PROG2 () 'T
(SETQ TEMP (CDDDR (LEVEL TAG)) N LY)
(SETQ N (LENGTH
(COND ((NOT #(NUMPDLP-N N))
(PROG2 () (CAR TEMP) (SETQ TEMP REGPDL)))
((NOT #(FLPDLP-N N))
(PROG2 () (CADR TEMP) (SETQ TEMP FXPDL)))
('T (PROG2 () (CADDR TEMP) (SETQ TEMP FLPDL)))))))
(> LY (CONVNUMLOC (SETQ N (- N (LENGTH TEMP)))
(AND (NOT (REGADP LY)) TYPY))))
(SETQ LY (COND ((NULL TYPY) (FRAC5))
(((LAMBDA (TAKENAC1) (FREENUMAC)) AC))))
(LOADAC Y/' LY () )
(RSTD TAG AC LY))
((AND (RSTD TAG AC 0) (NOT (PLUSP N)))
(SETQ LY (ILOC2 (VARBP (CAR Y/')) Y/' TYPY))))
(REMOVE Y/'))
((NULL TAG)
(REMOVE Y/')
(AND (OR (EQ (PROG2 (FIND ARGNO) (CPUSH1 ARGNO () LY)) 'PUSH)
(EQ (PROG2 (FIND AC) (CPUSH1 AC () LY)) 'PUSH))
#(PDLLOCP LY)
(SETQ LY (ILOC2 (VARBP (CAR Y/')) Y/' TYPY)))))
(SETQ TEMP (COND (#(EQUIV F TAG) '(CAMN)) ('T '(CAME))))
(COND (#(NUMACP-N AC) (OUT3 TEMP AC LY))
((OUT1 (CAR TEMP) AC LY)))
(AND TAG (OUTJ0 'JUMPA 0 TAG 'T () )) ))
(DEFUN NUMODIFY (X TYPX)
(COND ((NULL TYPX) () )
('T (SETQ X (ILOCMODE X 'FREENUMAC TYPX))
(AND #(NUMACP X)
((LAMBDA (ACX) (AND ACX (RPLACA ACX TYPX))) #(ACSMODESLOT X)))
X)))
;;; WOW! Has this function been overused. First it was for compiling ERRSET,
;;; but since all the CATCH things were similar, and so was UNWIND-PROTECT,
;;; and the PASS-THRU things, . . . well,
(DEFUN COMERSET (FUN Y)
#(LET ((GOBRKL GOBRKL)
(ARGNO 1)
(TAG (GENSYM))
ERSTP PASSP CATP
RSL V)
(CASEQ FUN (ERRSET (SETQ ERSTP 'T))
(%PASS-THRU (SETQ PASSP 'T))
((*CATCH CATCH %CATCHALL CATCH-BARRIER) (SETQ CATP 'T))
('T (BARF FUN |What type frame - COMERSET|)))
(COND ((OR PASSP (AND CATP (EQ FUN '%CATCHALL)))
#(LET ((FTAG (GENSYM)))
#(CLEARALLACS)
(COND (CATP #(OUTFS 'MOVEI T TAG) ; for CATCHALL
(OUTPUT '(JSP TT (ERSETUP -3))))
(PASSP (OUTPUT '(JSP TT PTNTRY)))) ; for PASS-THRU
#(OUTFS 'JUMPA 0 FTAG)
(|Oh, FOO!|)
(AND PASSP (PROG2 (STRETCHPDL LPASST-P+1 () )
(STRETCHPDL LPASST-FXP 'FIXNUM)))
(STRETCHPDL 1 () ) ;For ret addr of POPJ P below
(SETQ RSL (SLOTLISTCOPY))
(LOADAC (COMP1 (CAR Y)) 1 'T)
(RESTORE RSL)
(OUTPUT '(POPJ P))
(OUTPUT FTAG)
(SHRINKPDL 1 () )
(AND PASSP (PROG2 (SHRINKPDL LPASST-P+1 () )
(SHRINKPDL LPASST-FXP 'FIXNUM))) ))
('T (LOADAC (COMP1 (CAR (COND (ERSTP (CDR Y)) (Y)))) 1 'T) ; for CATCH varieties
(CLEARACS 2 'T () )
(CLEARNUMACS)
#(OUTFS 'MOVEI 2 TAG)
(OUTPUT (CASEQ FUN (ERRSET '(JSP TT ERSETUP))
((*CATCH CATCH) '(JSP TT (ERSETUP -1)))
(CATCH-BARRIER '(JSP TT (ERSETUP -2))) ))))
(STRETCHPDL LERSTP+1 () )
(SETQ RSL (SLOTLISTCOPY))
(PUSH (CONS (COND (CATP 'CATCH) (FUN)) RSL) GOBRKL)
(SETQ V (COND (ERSTP (COMP0 (COND ((AND EFFS (EQ (CAAR Y) 'NCONS)) ;Value from ERRSET will
(CADAR Y)) ; will generally be
((CAR Y))))) ; in 1 since it is
('T (COMPROGN (CDR Y) EFFS)))) ; of form (NCONS FOO)
(COND ((AND (NOT EFFS) (NOT (EQUAL 1 (ILOC0 V () ))))
(LOADAC V 1 'T) ;But CATCH isn't
(RPLACA REGACS (SETQ V (LIST (GENSYM)))) ; always so lucky,
(PUSH V LDLST))) ; so put it in 1
(RESTORE RSL)
(AND (OR (CLEARVARS) (CLEARNUMACS))
(BARF () |Lose lose - COMERSET|))
(OUTPUT (COND (ERSTP (AND EFFS (OUTPUT '(MOVEI 1 'T))) ;Break up frame of
'(JRST 0 ERUNDO)) ; ERRSET
(PASSP '(JSP TT PTEXIT)) ; PASS-THRU
(CATP '(JRST 0 (ERUNDO -2))))) ; nearest CATCH
(SHRINKPDL LERSTP+1 () )
(OUTPUT TAG)
(AND (NOT EFFS) (REMOVE V))
(SETQ CNT (+ CNT 2))
V))
(DEFUN COMFIXFLT (ITEM MODE) ;MODE IS ALWAYS EITHER "FIXNUM" OR "FLONUM"
(COND ((EQ (CAR ITEM) 'QUOTE)
(WARN ITEM |QUOTE stuff in COMFIXFLT - show this to JONL|)
(REMOVE ITEM)
((LAMBDA (TYPE)
(COND ((MEMQ TYPE '(FIXNUM BIGNUM))
(COND ((EQ MODE 'FIXNUM)
(COND ((EQ TYPE 'BIGNUM)
(PDERR (CADR ITEM) |Too big to be FIXNUM|)
(SETQ ITEM '0)))
ITEM)
((LIST 'QUOTE (FLOAT (CADR ITEM))))))
((EQ MODE 'FLONUM) ITEM)
((LIST 'QUOTE (FIX (CADR ITEM))))))
(TYPEP (CADR ITEM))))
('T (LOADAC ITEM #(NUMVALAC) () )
(COND ((EQ MODE 'FIXNUM) (CPUSH ##(1+ (NUMVALAC)))
(RPLACA (CDR NUMACS) () )))
(OUTPUT (COND ((EQ MODE 'FIXNUM) '(JSP T IFIX))
('(JSP T IFLOAT))))
(RPLACA ACSMODE MODE) ;(SETMODE ACSMODE MODE)
(CAR (RPLACA NUMACS (LIST (GENSYM))))))) ;(CONT #(NUMVALAC) (LIST (GENSYM)))
(DEFUN COMGO (Y)
(COND ((ATOM (CAR Y))
(COMGORET (ADR (CAR Y)) 0))
('T (CPVRL)
(LOADAC (COMP1 (CAR Y)) 1 'T)
(COMGORET (GENTAG 'VGO) 1))))
(DEFUN COMGORET (TAG AC)
(CPVRL)
(CLEARVARS)
(COND ((EASYGO) (OJRST TAG AC))
('T (CLEARNUMACS)
((LAMBDA (L LDLST CNT)
(MAPC '(LAMBDA (Y) (AND (EQ (CAR Y) 'UNBIND)
(CDR Y)
(SETQ CNT (CDR Y))))
GOBRKL)
(MAPC '(LAMBDA (Y)
(COND ((EQ (CAR Y) 'UNBIND) (OUTPUT '(PUSHJ P UNBIND)))
('T (RESTORE (CDR Y))
(OUTPUT
(COND ((EQ (CAR Y) 'ERRSET) ;For ERRSETs
'(JSP T GOBRK))
((EQ (CAR Y) 'CATCH)
'(JSP T (GOBRK -1))) ;For CATCHs
('(JSP TT UNWINE))))
(SHRINKPDL LERSTP+1 () ))))
GOBRKL)
(COND ((NULL L-END-CNT))
((> L-END-CNT CNT) (SETQ CNT L-END-CNT)))
(OJRST TAG AC)
(SLOTLISTSET L))
(SLOTLISTCOPY) PROGP CNT))))
(DEFUN COMHAULONG (Y)
((LAMBDA (ARGNO ACX EFFS)
(LOADAC (COMP0 (CADR Y)) ARGNO () )
(SETQ ACX (COND ((= ARGNO #(NUMVALAC)) (+ 2 #(NUMVALAC)))
(#(NUMVALAC))))
(COND ((AND (NOT ATPL)
(EQ (CAR LOUT) 'MOVE)
(FIXP (CADR LOUT))
(= (CADR LOUT) ARGNO))
(SETQ LOUT (CONS 'MOVM (CDR LOUT))))
(#(OUTFS 'MOVMS 0 ARGNO)))
(CLEARNUMACS)
(MAPC 'OUTPUT
(COND ((AND (= ACX #(NUMVALAC)) (= ARGNO (1+ #(NUMVALAC))))
##(SUBLIS (LIST (CONS 'TT (NUMVALAC)) (CONS 'D (1+ (NUMVALAC))) (CONS 'R (+ 2 (NUMVALAC))))
''((MOVEI TT 36.) (JFFO D (* 2)) (TDZA TT TT) (SUBI TT 0 R))))
((AND (= ACX (+ 2 #(NUMVALAC))) (= ARGNO #(NUMVALAC)))
##(SUBLIS (LIST (CONS 'TT (NUMVALAC)) (CONS 'D (1+ (NUMVALAC))) (CONS 'R (+ 2 (NUMVALAC))))
''((MOVEI R 36.) (JFFO TT (* 2)) (TDZA R R) (SUBI R 0 D))))
((BARF (LIST ARGNO ACX) |Lose lose - COMHAULONG|))))
(SETMODE ACX 'FIXNUM)
(CAR (CONT ACX (LIST (GENSYM)))))
(COND ((= ARGNO #(NUMVALAC)) (1+ #(NUMVALAC)))
(#(NUMVALAC)))
()
()))
;;; Chart of how COMGRTLSP works, using LESSP for example
;;; (LESSP A B), which is not 2LONG, and
;;; (LESSP A B C D), which is 2LONG
;;; P1 is the comparison between A and B, P2 between B and C,
;;; P3 between C and D. In the normal sense of the test, the
;;; result is either a JUMP to a TAG, or a SKIP of one instruction.
;;; In the inverted sense, the logical sense of the test is
;;; complemented. The argument "F" is non-null for the normal sense.
;;; Examples for the 2LONG case follow. After it are the
;;; examples for the not-2LONG case.
;;; When TAG is supplied, and there is no level problem with it
;;; Normal Inverted
;;; ---------------- --------------
;;; CAIL P1 CAIL P1
;;; JRST LOSE JRST TAG
;;; CAIL P2 CAIL P2
;;; JRST LOSE JRST TAG
;;; |CAIGE| P3 CAIL P3
;;; JRST TAG JRST TAG
;;; LOSE: . . .
;;; When TAG is supplied, and there is a level problem
;;; Normal Inverted
;;; ---------------- --------------
;;; CAIL P1 CAIL P1
;;; JRST LOSE JRST WIN
;;; CAIL P2 CAIL P2
;;; JRST LOSE JRST WIN
;;; CAIL P3 |CAIGE| P3
;;; JRST LOSE JRST LOSE
;;; [PDL corrections] WIN: [PDL corrections]
;;; JRST TAG JRST TAG
;;; LOSE: ... LOSE: . . .
;;; When no TAG is supplied
;;; Normal Inverted
;;; ---------------- --------------
;;; CAIL P1 CAIL P1
;;; JRST LOSE JRST WIN
;;; CAIL P2 CAIL P2
;;; JRST LOSE JRST WIN
;;; CAIL P3 CAIL P3
;;; LOSE: . . . WIN: SKIPA
;;; For all cases which are not-2LONG
;;; With TAG, normal With TAG, inverted
;;; ---------------- --------------
;;; |CAIGE| P1 CAIL P1
;;; JRST TAG JRST TAG
;;; No TAG, normal No TAG, inverted
;;; ---------------- --------------
;;; CAIL P1 |CAIGE| P1
(DEFUN COMGRTLSP (EXP TAG F)
(PROG (ARGL TYPEL MODE ARG1 ARG2 AC AD OP BTAG CTAG B2F SAVE FL 2LONG)
(SETQ TYPEL (COND ((NULL (CADR EXP)) (SETQ OP 'FIXNUM) '(()) )
((NOT (MEMQ (CADR EXP) '(FIXNUM FLONUM))) (CADR EXP))
((NCONS (SETQ OP (CADR EXP))))))
(SETQ ARGL ((LAMBDA (ARGNO EFFS)
(MAPCAR '(LAMBDA (X)
(SETQ SAVE (COMP0 X))
(NUMODIFY SAVE OP)
SAVE)
(CDDR EXP)))
#(NUMVALAC) () ))
(SETQ 2LONG (CDDR ARGL))
(COND ((AND TAG
(NOT 2LONG)
(OR (Q0P+0P (SETQ ARG1 (CAR ARGL)))
(Q0P+0P (SETQ ARG2 (CADR ARGL)))))
(SETQ OP (COND ((EQ (CAR EXP) 'LESSP) 'JUMPL)
((EQ (CAR EXP) 'GREATERP) 'JUMPG)
((GO BARF))))
(SETQ ARG2 (COND (ARG2 (REMOVE ARG2) ARG1)
('T (SETQ OP (GET OP 'COMMU))
(REMOVE ARG1)
(CADR ARGL))))
(OUTJ (COND (F OP) ((GET OP 'CONV)))
(LOADINNUMAC ARG2 0 () 'REMOVE)
TAG)
(RETURN 'T)))
(SETQ MODE (CAR TYPEL) ARG1 (CAR ARGL))
(SETQ OP (COND ((EQ (CAR EXP) 'LESSP) 'CAML)
((EQ (CAR EXP) 'GREATERP) 'CAMG)
((GO BARF))))
(SETQ BTAG (COND ((NOT 2LONG)
(AND #(EQUIV TAG F)
(SETQ OP (GET OP 'CONV)))
TAG)
('T (FREEIFYNUMAC)
(SETQ CTAG (LEVELTAG))
(COND ((NULL TAG) CTAG)
('T (AND (BADTAGP TAG) (SETQ B2F CTAG))
(COND ((OR F B2F) CTAG)
(TAG)))))))
(DO ((ARGL (CDR ARGL) (CDR ARGL)))
((NULL ARGL))
(SETQ ARG2 (CAR ARGL) TYPEL (OR (CDR TYPEL) TYPEL))
(COND ((NOT (EQ MODE (CAR TYPEL)))
(COND ((EQ MODE 'FIXNUM)
(SETQ ARG1 (COMFIXFLT ARG1 (SETQ MODE 'FLONUM))))
((SETQ ARG2 (COMFIXFLT ARG2 'FLONUM))))))
(COND ((AND (NOT #(ACLOCP (SETQ AD (ILOCMODE ARG1 'FREENUMAC MODE))))
(PROG2 (SETQ SAVE (ILOCMODE ARG2 'FREENUMAC MODE)) 'T)
(COND (#(NUMACP SAVE) (REMOVE ARG2) 'T)
((EQ (CAR ARG1) 'QUOTE)
(SETQ SAVE (LOADINNUMAC ARG2 0 () 'REMOVE))
'T)))
(SETQ AC SAVE FL 'T SAVE ARG1))
('T (COND (#(NUMACP AD)
(SETQ AC AD))
((SETQ AC (LOADINNUMAC ARG1 0 () 'REMOVE))))
(REMOVE ARG1)
((LAMBDA (TAKENAC1) (SETQ AD (ILOCMODE ARG2 'FREENUMAC MODE))) AC)
(SETQ SAVE ARG2 FL () )))
(COND ((OR (NULL 2LONG) (CDR ARGL))) ;Fix up last clause of 2LONGs
((NULL TAG) (SETQ BTAG () )) ; for reversal of condition
((AND F (NULL B2F)) (SETQ BTAG TAG OP (GET OP 'CONV)))
((AND (NULL F) B2F)
(PUTPROP (SETQ BTAG (SETQ CTAG (GENSYM)))
(GET B2F 'LEVEL)
'LEVEL)
(SETQ OP (GET OP 'CONV))))
(COND (TAG (AND (RSTD BTAG AC 0)
(NUMBERP AD)
(SETQ AD (ILOC2 (VARBP (CAR SAVE)) SAVE MODE)))
(REMOVEB SAVE)
(CLEARVARS))
('T (REMOVE SAVE)
(AND (OR (EQ (PROG2 (FIND ARGNO) (CPUSH1 ARGNO () AD)) 'PUSH)
(EQ (PROG2 (FIND AC) (CPUSH1 AC () AD)) 'PUSH))
#(PDLLOCP AD)
(SETQ AD (ILOC2 (VARBP (CAR SAVE)) SAVE MODE)))))
(OUT3 (ASSQ (COND ((NULL FL) OP) ((GET OP 'COMMU)))
'((CAML) (CAMLE) (CAMG) (CAMGE)))
AC
AD)
(AND BTAG (OUTJ0 'JUMPA 0 BTAG 'T 0))
(SETQ ARG1 ARG2))
(COND (CTAG (COND (B2F (AND (NULL F) (OUTTAG B2F))
(OUTJ0 'JRST 0 TAG 'T 0)))
(OUTTAG-TO-LEVEL CTAG)
(AND (NULL TAG) (NULL F) (OUTPUT '(SKIPA)))))
(RETURN () )
BARF (BARF EXP |This is no fun - COMGRTLSP|)))
(DEFUN COMLAM (X Y)
;;; X = (LAMBDA complexity setqlist <specvars . modelist> lamvars body endcount lamunsf nlnvthtbp)
#(LET ((OLVRL OLVRL) (BVARS BVARS) (GOBRKL GOBRKL) (MODELIST (CADDDR X))
(CONDPNOB PNOB) (LLL (CDDDDR X))
SPECVARS LARG SPFL LMRSL MODE TEM PNOB ITEM)
(SETQ SPECVARS (CAR MODELIST) MODELIST (CDR MODELIST))
(CLEAR (CADDR X) () ) ;Check out the SETQ-list
(COND ((MEMQ PROGN (CADDR X)) (CLEARACS0 () )) ;but not vars that will go out
('T ((LAMBDA (CNT) (CLEARVARS)) (CADDR LLL)))) ;of date during LAMBDA
(SETQ LMRSL (SLOTLISTCOPY)) ;Remember how deep the slotlist is
(CNPUSH (CAR (CDDDDR LLL)) () ) ;Push NLNVTHTBP
(AND Y ;Compute up arglist, iloc items,
(PROG (SPLL1 SPLLV RGLLL RGLLM LMQL VMS N LARGSLOTP) ;Keep track of QUOTE stuff for
(SETQ VMS (MAPCAR 'VARMODE (CAR LLL))) ;efficient binding, and separate
(DO ((VAR (REVERSE (CAR LLL)) (CDR VAR)) ;out items for SPECIAL vars
(TYPEL (REVERSE VMS) (CDR TYPEL))
(ACLQ 'T) ;Hac to help find free acs
(AARGS (DO ((EFFS) (T1) (ARGNO 1) (AARGS) (TYPEL VMS (CDR TYPEL))
(Y Y (CDR Y)) (VAR (CAR LLL) (CDR VAR)))
((NULL Y) AARGS)
(COND ((NULL (CAR VAR)) (PUSH (COMPE (CAR Y)) AARGS))
((AND (NOT (SETQ SPFL (SPECIALP (CAR VAR))))
(CAR TYPEL))
(PUSH (COMPW (CAR Y) () #(NUMVALAC)) AARGS)
(COMLOCMODE (CAR AARGS) 'FREENUMAC (CAR TYPEL) (CAR VAR)))
('T (SETQ TEM PNOB ;PNOB prohibited
PNOB (AND (NOT SPFL) (CAR VAR)) ; on special vars
T1 (COMP0 (CAR Y))
PNOB TEM)
(PUSH (OR (MAKESURE (CAR Y) (CAR VAR) SPFL T1 #(ILOCN T1))
T1)
AARGS))))
(CDR AARGS)))
((NULL VAR))
(AND (NULL (CAR VAR)) (GO DOX))
(SETQ SPFL (SPECIALP (CAR VAR)))
(SETQ MODE (AND (NOT SPFL) (CAR TYPEL)))
(SETQ LARG (ILOCMODE (CAR AARGS) () MODE))
(REMOVE (CAR AARGS))
(SETQ LARGSLOTP (NUMBERP LARG))
(COND ((AND (NOT LARGSLOTP) (NULL (CDR LARG)))
(COND ((AND SPFL (NOT (QNILP (CAR LARG))) (NOT (ASSOC LARG LMQL)))
(COND ((NULL ACLQ) (SETQ N 0))
((NOT (ZEROP (SETQ N (FRACB)))))
((EQ ACLQ 'CLEARVARS) (SETQ ACLQ () ))
('T (CLEARVARS) (SETQ ACLQ 'CLEARVARS N (FRACB))))
(COND ((ZEROP N)
(OPUSH LARG (SETQ ITEM (CONS (CAR VAR) 'TAKEN)) MODE))
('T (PUSH (CONS LARG N) LMQL)
(OUT1 'MOVE N LARG)
(CONT N (CONS LARG 'TAKEN))
(SETQ ITEM (CONS (CAR VAR) LARG)))))
('T (SETQ ITEM (CONS (CAR VAR) LARG)))))
('T (COND ((COND (LARGSLOTP (COND ((AND (NOT MODE) (NOT (REGADP LARG)))
() )
('T (FIND LARG)
(AND (> LARG 0)
SPFL
(CPUSH1 LARG 'T () ))
(NOT (DVP1 SLOTX LARG)))))
((AND SPFL (NOT (ZEROP (SETQ N (LOADINREGAC
(CAR AARGS)
'FRACB
() )))))
(SETQ LARG N)
'T)
('T (AND (NOT (EQ (CAR LARG) 'SPECIAL))
(BARF LARG |Not LARGSLOTP - COMLAM|))
(OPUSH LARG () MODE)
(SETQ LARG (CONVNUMLOC 0 MODE))
'T))
(CONT LARG (SETQ ITEM (CONS (CAR VAR) 'TAKEN))))
('T (SETQ ITEM (CONS (CAR VAR) (CONS 'ILOC0 (CAR AARGS))))
(PUSH (CAR AARGS) LDLST)))))
(COND (SPFL (PUSH ITEM SPLL1) (PUSH (CAR VAR) SPLLV))
('T (PUSH MODE RGLLM) (PUSH ITEM RGLLL)))
DOX )
(SETQ SPFL (PROGHACSET SPLL1 (CADR LLL)))
; Cause the LAMBDA bindings to happen
(MAPC
'(LAMBDA (VAR MODE)
(COND ((EQ (CDR VAR) 'TAKEN) ;(VAR . TAKEN)
(RPLACD VAR () ))
((AND (NULL (CDDR VAR)) ;(VAR . ((QUOTE () )))
(OR (QNILP (CADR VAR)) ;(VAR . ((QUOTE 0)))
(AND MODE (Q0P+0P (CADR VAR)))))
(PUSH (CAR VAR) OLVRL))
('T
(SETQ TEM (COND ((EQ (CADR VAR) 'ILOC0) ;(VAR . (ILOC0 . QUANT))
#(ILOCF (CDDR VAR)))
('T (CDR VAR)))) ;(VAR . ((QUOTE THING)))
(COND ((AND (NOT MODE) (NOT (REGADP TEM)))
(SETQ N (FRACB))
(COND ((ZEROP N) (CLEARVARS) (SETQ N (FRACB))))
(AND (ZEROP N) (BARF REGACS |COMLAM acs lossage|))
(AND (NOT (MEMQ (CAR VAR) UNSFLST))
(BARF (LIST (CAR VAR) TEM) |Unsafe var - COMLAM|))
(MAKEPDLNUM (CDDR VAR) N)
(CONT N (LIST (CAR VAR))))
('T (AND (EQ (CADR VAR) 'ILOC0) (REMOVEB (CDDR VAR)))
(OPUSH TEM (LIST (CAR VAR)) MODE))))))
RGLLL RGLLM)
;;; For binding to a special var, the item must be in an accumulator
;;; and a call to the pseudo function SPECBIND is made
(COND (SPLL1 (CPUSH (+ #(NUMVALAC) 2)) ;SPECBIND uses acc R [= 11 = TT+2]
(OUTPUT '(JSP T SPECBIND))
(MAPC '(LAMBDA (VAR)
(MAP '(LAMBDA (SL) ;Kill REGAC slots
(AND (SETQ ITEM (CAR SL)) ; with specbound vars
(EQ (CAR ITEM) (CAR VAR))
(MEMQ (CDR ITEM) '(DUP () ))
(RPLACA SL () )))
REGACS)
(SETQ LARG
(COND ((EQ (CDR VAR) 'TAKEN)
(RPLACD VAR CNT)
(SETQ LARG (ILOC1 'T VAR () ))
(COND ((NOT (NUMBERP LARG))
(BARF () |Lost TAKEN - COMLAM|))
((PROG2 (SETQ N LARG) #(PDLLOCP N))
(CONT LARG () )))
(RPLACD VAR 'DUP)
LARG)
((QNILP (CADR VAR)) () )
((EQ (CADR VAR) 'ILOC0)
(SETQ TEM (PROG2 ()
#(ILOCF (SETQ TEM (CDDR VAR)))
(REMOVEB TEM)))
(COND (#(PDLLOCP TEM)
(AND (NOT (DVP TEM)) (RPLACA SLOTX () ))
TEM)
('T (BARF TEM |Lost ILOC0 - COMLAM|))))
((SETQ LARG (ASSOC (CDR VAR) LMQL))
(CONT (CDR LARG) (LIST (CAR VAR)))
(CDR LARG))
('T (BARF () |Lost entirely - COMLAM|))))
(OSPB LARG (CAR VAR)))
SPLL1)
(DIDUP SPLLV)
(MAPC 'CARCDR-FREEZE SPLLV (CAR COMAL)) ;(CAR COMAL) has infinite list of ()s
(PUSH (CONS 'UNBIND (CADDR LLL)) GOBRKL)))))
; EXECUTE LAMBDA BODY AND RESTORE SLOTLIST
(SETQ BVARS (APPEND (CAR LLL) BVARS))
(SETQ ITEM ((LAMBDA (PNOB L-END-CNT) (COMP0 (CADR LLL)))
CONDPNOB (OR L-END-CNT (CADDR LLL)))
TEM () )
(COND ((AND (NOT EFFS)
(NOT (EQ (CAR ITEM) 'QUOTE))
(PROG2 (SETQ TEM (MEMQ (CAR ITEM) (CAR LLL)) Y #(ILOCN ITEM))
(OR TEM (NOT #(ACLOCP Y)))))
(SETQ LARG (COND (#(NUMACP-N ARGNO) (LOADINNUMAC ITEM ARGNO Y 'REMOVEB))
((AND (OR TEM (NOT CONDPNOB))
(OR (NOT (REGADP Y)) (UNSAFEP ITEM)))
(LOADAC ITEM 1 'T)
1)
((LOADINREGAC ITEM ARGNO Y))))
(AND (OR TEM (NOT (EQUAL ITEM (CONTENTS LARG))))
(CONT LARG (SETQ ITEM (LIST (GENSYM)))))
(PUSH ITEM LDLST)))
(COND ((AND (L/.LE/. (CAR (SETQ TEM (CDDDR LMRSL))) REGPDL)
(L/.LE/. (CADR TEM) FXPDL)
(L/.LE/. (CADDR TEM) FLPDL))
(RESTORE LMRSL))
('T (DO Z '(REGACS () NUMACS () REGPDL 0 FXPDL ##(FXP0) FLPDL ##(FLP0))
(CDDR Z)
(NULL Z)
(DO ((SLOTL (SYMEVAL (CAR Z)) (CDR SLOTL)) (I 0 (1+ I)))
((NULL SLOTL))
(AND (CAR SLOTL)
(MEMQ (CAAR SLOTL) (CAR LLL))
(RPLACA SLOTL () ))))))
(SETQ CNT (1+ CNT))
(COND (SPFL (OUTPUT '(PUSHJ P UNBIND))))
(DIDUP (CADDR X))
(CLEANUPSPL () )
(REMOVE ITEM)
ITEM))
(DEFUN COMLC (X Y ITEMFL)
; Compile a CALL to an L-FORM - P1 places L-type CALLs within
; the scope of an internal LAMBDA application like
; ((LAMBDA () (LCALL * *))
; Thus a CLEAR is done by COMLAM)
((LAMBDA (OARGNO ARGNO OPNOB PNOB)
(PROG (NARGS Z TAG LZ RSL PDLTP)
(SETQ NARGS (LENGTH Y))
(COND ((NOT (ATOM X))
(AND (EQ (CAR X) COMP) #(ILOCF (CADDR X))))
((ZEROP NARGS)
(CLEARACS1 X 'GENSYM) ;Remembering that COMLAM has CLEARVARS'd
(OUTPUT '(MOVEI T 0))
(SETQ ARGNO OARGNO PNOB OPNOB)
(RETURN (COML1 X 'CALL))))
(CLEARACS ##(+ (NACS) (NUMNACS)) () 'GENSYM) ;Remembering that COMLAM has CLEARVARS'd
(SETQ TAG (RETURNTAG))
(SETQ PDLTP (LIST (APPEND REGPDL '())))
(SETQ RSL (APPEND '(() () () ) PDLTP))
(MAPC
'(LAMBDA (ARG)
(SETQ LZ #(ILOCREG (SETQ Z (COND (ITEMFL ARG)
('T (COMPW ARG () 1))))
1))
(RESTORE RSL)
(COND ((NOT (REGADP LZ)) (MAKEPDLNUM Z (SETQ LZ (FRACB))))
((REMOVEB Z)))
(COND ((AND #(ACLOCP LZ)
(NOT ATPL)
(EQ (CAR LOUT) 'SUB)
(EQ (CADR LOUT) 'P)
(EQUAL LOUT '(SUB P (% 0 0 1 1))))
(SETQ LOUT (SETQ ATPL 'FOO))
(OUT1 'MOVEM LZ 0)
(PUSH '(NIL . TAKEN) REGPDL))
('T (AND #(PDLLOCP LZ) (SETQ LZ (ILOC0 Z () )))
(OPUSH LZ '(NIL . TAKEN) () )))
(RPLACA PDLTP (CONS '(NIL . TAKEN) (CAR PDLTP))))
Y)
(AND (CLEARACS0 () ) ;Check for importent things
(BARF () |Too much value - COMLC|)) ; being inadvertently left in ACs
(CLEARACS1 X () ) ;Clobber out the ACs to be used
#(OUTFS 'MOVNI 'T NARGS)
(SETQ ARGNO OARGNO PNOB OPNOB)
(SETQ Z (COML1 X 'JCALL))
(OUTPUT TAG)
(SHRINKPDL (1+ NARGS) () )
(RETURN Z)))
(COND ((AND (EQ (CAR X) COMP) (EQ (CADR X) 'FUNCALL)) 1)
((OR PNOB #(NUMACP-N ARGNO)) ARGNO)
(1))
1
PNOB
'T))
(DEFUN COML1 (X OP)
(COND ((EQ (CAR X) COMP)
((LAMBDA (LOC INST)
(REMOVEB (CADDR X))
(COND (INST (SETQ INST (COND ((EQ OP 'CALL) (CAR INST))
((CADR INST))))
(OUT1 (CAR INST) (CADR INST) LOC)
1)
('T (OUT1 'MOVE #(NUMVALAC) LOC)
(OUTPUT (COND ((EQ OP 'CALL) '(PUSHJ P @ 1 ##(NUMVALAC)))
('T '(JRST 0 @ 1 ##(NUMVALAC)))))
(RPLACA ACSMODE (CADR X))
#(NUMVALAC))))
#(ILOCF (CADDR X))
(COND ((EQ (CADR X) 'FUNCALL) '(((CALLF) 16) ((JCALLF) 16)))
((NULL (CADR X)) '(((PUSHJ) P) ((JRST) 0))))))
((OUTFUNCALL OP 16 X))))
(DEFUN COMLOCMODE (ITEM FUN MODE VAR)
((LAMBDA (LARG NLARG OPPOSER)
(SETQ OPPOSER (COND ((NOT (NUMBERP LARG))
(COND ((EQ (CAR LARG) 'SPECIAL) (VARMODE (CADR LARG)))
((EQ (CAAR LARG) 'QUOTE)
(CAR (MEMQ (TYPEP (CADAR LARG)) '(FIXNUM FLONUM))))))
((PROG2 (SETQ NLARG LARG) #(NUMACP-N NLARG))
(COND ((GETMODE0 LARG 'T () ))
('T (SETMODE LARG MODE) MODE)))
(#(NUMPDLP-N NLARG)
(COND (#(FLPDLP-N NLARG) 'FLONUM)
('FIXNUM)))
((GETMODE LARG))
('T MODE)))
(AND OPPOSER
(NOT (EQ MODE OPPOSER))
(DBARF (LIST (CONS VAR MODE) (CONS ITEM OPPOSER))
|Binding number variable to quantity of wrong type|))
0
LARG)
#(ILOCNUM ITEM FUN)
0
()))
;;; Dont try to substitute ILOC1 or ILOC2 for this ILOCNUM -
;;; You have to satisfy conflicts between the REGWORLD and NUMWORLD
(DEFUN COMNULL (Y)
((LAMBDA (LY TEM FL N)
(COND ((NOT EFFS)
(COND ((CCHAK-BOOL1ABLE Y () ))
('T (SETQ TEM (COMP0 Y) LY #(ILOCREG TEM ARGNO)
FL (NUMBERP LY))
(AND FL (SETQ N LY))
(REMOVEB TEM)
(FIND ARGNO)
(AND (CPUSH1 ARGNO () LY)
FL
#(REGPDLP-N N)
(SETQ FL (NUMBERP (SETQ LY (ILOC0 TEM () ))))
(SETQ N LY))
(COND ((AND FL #(ACLOCP-N N)) (OUTPUT (BOLA N 3)))
('T (OUT1 'SKIPE 0 LY)))))
(BOOLOUT () () ))
((COMPE Y))))
() () () 0))
(DEFUN COMPROG (Y)
;;; Y = (complexity setqlist golist <specvars . modelist> progvars progbody progunsf nlnvthtbp)
(AND (NULL SFLG) (CLEAR (CADR Y) 'T))
((LAMBDA (PVR OPVRL PROGTYPE SPFL OEFFS ARGNO EFFS EXLDL PROGP)
(PROG (EXIT EXITN LPRSL PRSSL GOBRKL VGO GL PVRL SPECVARS MODELIST
PNOB FL TEM LY L-END-CNT)
(SETQ MODELIST (CAR (SETQ LY (CDDDR Y)))
SPECVARS (CAR MODELIST) MODELIST (CDR MODELIST))
(MAPC '(LAMBDA (X)
(AND (SPECIALP X)
(PROG2 (COND ((NULL SPFL)
(SETQ SPFL 'T)
(CPUSH ##(+ (NUMVALAC) 2))
(OUTPUT '(JSP T SPECBIND))))
(OSPB () X))))
(CADR LY))
(COND (SFLG (CLEAR (CADR Y) 'T) (SETQ SFLG () )))
(SETQ CNT (ADD1 CNT))
(SETQ GL (CADDR Y))
(SETQ PVRL (MAPCAN '(LAMBDA (X) (AND (NOT (SPECIALP X)) (LIST X)))
(CAR (SETQ LY (CDR LY)))))
(CNPUSH (CADDR (SETQ LY (CDR LY))) () ) ;Push NLNVTHTBP
(MAP '(LAMBDA (X)
(SETQ CNT (ADD1 CNT))
(COND ((ATOM (CAR X))
(COND ((SETQ TEM (ADR (CAR X)))
#(CLEARALLACS)
(CPVRL)
(RESTORE PRSSL)
(COND ((NOT ATPL) (PUTPROP TEM LOUT 'PREVI)))
(OUTTAG0 TEM)
(CLEANUPSPL () ))))
((AND (NULL (CDR X)) (EQ (CAAR X) 'RETURN))
(COMRETURN (CDAR X) () )
(SETQ FL 'T))
('T (COND ((EQ (CAAR X) 'COND)
(AND (MEMQ GOFOO (CADDAR X)) (RESTORE PRSSL))
(COMCOND (CDAR X)
()
()
(AND (CDR X)
(EQ (CAADR X) 'GO)
(ATOM (SETQ TEM (CADADR X)))
(ADR TEM))))
('T (COMPW (CAR X) 'T 1))))))
(CAR LY))
(COND ((AND (NULL LPRSL)
(COND ((NULL EXIT)
(AND (NOT OEFFS) (CMPRGLDNIL 'T))
'T)
((NULL EXITN))))
(CLEANUPSPL () )
(SETQ CNT (+ CNT 2))
#(CLEARALLACS))
('T (SETQ FL (NOT (OR FL (AND (NOT ATPL) (MEMQ (CAR LOUT) '(JRST JUMPA))))))
(OUTTAG EXITN)
(AND (NOT OEFFS) (CMPRGLDNIL FL))
(OUTTAG EXIT)
#(CLEARALLACS)
(OR EXIT EXITN (CLEANUPSPL () ))
(SETQ CNT (+ CNT 2))))
(COND (SPFL (CPUSH ##(+ (NUMVALAC) 2)) (OUTPUT '(PUSHJ P UNBIND))))
(DIDUP (CADR Y))
(AND VGO (PUSH (CONS VGO (GCDR 'CAAR GL)) VGOL))
(RETURN PROGTYPE)))
(COND ((OR (AND (NOT EFFS) (NOT (= ARGNO 1)) (< (CAR Y) 2))
#(NUMACP-N ARGNO))
ARGNO)
(1))
(LJOIN OPVRL PVRL)
() SFLG EFFS 1 1 LDLST LDLST))
(DEFUN COMPROGN (L OEFFS)
(AND L (DO ((Z L (CDR Z)) (EFFS 'T))
((NULL (CDR Z)) (SETQ EFFS OEFFS) (COMP0 (CAR Z)))
(COMP0 (CAR Z)))))
(DEFUN CMPRGLDNIL (FL)
(AND (OR FL EXITN)
(COND (#(NUMACP-N PVR) (LOADAC '(QUOTE 0) PVR () ))
((NOT (QNILP (CONTENTS PVR))) (LOADAC '(QUOTE () ) PVR 'T)))))
(DEFUN COMRETURN (Y GOP)
((LAMBDA (ARGNO)
(COND ((QNILP (CAR Y))
(GENTAG 'EXITN)
(AND GOP (COMGORET EXITN 0)))
('T ((LAMBDA (PNOB ARGNO EFFS)
(LOADAC (COMP0 (CAR Y)) PVR 'T))
() PVR ())
(AND #(NUMACP-N PVR)
(SETQ Y (CAR #(ACSMODESLOT PVR)))
(COND ((NULL PROGTYPE) (SETQ PROGTYPE Y))
((NOT (EQ PROGTYPE Y)) (SETQ PROGTYPE 'FIXNUM))))
(GENTAG 'EXIT)
(AND (OR GOP EXITN) (COMGORET EXIT PVR)))))
PVR))
(DEFUN COMREMAINDER (ARGL)
(DO ((ARGNO #(NUMVALAC)) (TAKENAC1 TAKENAC1) (EFFS) (ARG1) (ARG2) (AC) (LARG) (SVSLT))
()
(SETQ ARG1 (COMP0 (CAR ARGL))
ARGNO #(NUMVALAC)
ARG2 (COMP0 (CADR ARGL)))
(SETQ TAKENAC1 (1- (+ #(NUMVALAC) #(NUMNACS))) AC (FREENUMAC))
(SETQ LARG #(ILOCNUM ARG1 #(NUMVALAC)))
(COND ((AND #(NUMACP LARG)
(< LARG ##(1- (+ (NUMVALAC) (NUMNACS)))))
(REMOVEB ARG1)
(SETQ AC LARG))
((LOADINNUMAC ARG1 AC () 'REMOVEB)))
(FIND AC)
(CPUSH1 AC () () )
(RPLACA SLOTX '(NIL . TAKEN))
(SETQ SLOTX (CDR (SETQ SVSLT SLOTX))) ;Setup for entry to CPUSH1
(CPUSH1 (1+ AC) () () )
(SETQ LARG #(ILOCNUM ARG2 (1+ AC)))
(REMOVEB ARG2)
(OUT3 '(IDIV) AC LARG)
(SETQ LARG #(ACSMODESLOT AC))
(AND (NULL (CDR LARG)) (BARF AC |Whats this ac doing here -COMREMAINDER|))
(RPLACA LARG () ) ;SETMODE AC NIL
(RPLACA (CDR LARG) 'FIXNUM) ;SETMODE AC+1 'FIXNUM
(RPLACA SVSLT () ) ;CONT AC ()
(RETURN (CAR (RPLACA (CDR SVSLT) (LIST (GENSYM)))))))
(DEFUN COMSHIFTS (OP AARGS)
((LAMBDA (EFFS ARGNO ARG1 ARG2 TAKENAC1)
(SETQ ARG1 (COMP0 (CAR AARGS)) ARG2 (COMP0 (CADR AARGS)))
(SETQ TAKENAC1 (LOADINSOMENUMAC ARG1))
(SETQ ARG1 (COND ((EQ (CAR ARG2) 'QUOTE) (REMOVE ARG2) (CADR ARG2))))
(COND ((COND ((NULL ARG1) () )
((EQ OP 'FSC) (> ARG1 262143.)) ;FSC N,HUGE leaves unnormalized
((= ARG1 0)))) ;LSH.ROT N,0 does nothing
('T (SETQ ARG2 (COND (ARG1 (LIST ARG1))
((LIST 0 (LOADINSOMENUMAC ARG2)))))
(AND (NOT ARG1)
(EQ OP 'FSC)
#(OUTFS 'CAIG (CADR ARG2) 262143.))
(OUTPUT (CONS OP (CONS TAKENAC1 ARG2)))))
(SETMODE TAKENAC1 (COND ((EQ OP 'FSC) 'FLONUM) ('FIXNUM)))
(CAR (CONT TAKENAC1 (LIST (GENSYM)))))
() #(NUMVALAC) () () 0))
(DEFUN COMRPLAC (FUN L VAL)
(PROG (X Y LX LY OCNT)
(CSLD () 'T () ) ;Grabs in only CARCDR loadings
(SETQ OCNT CNT)
((LAMBDA (PNOB EFFS ARGNO)
(SETQ X (COMP0 (CAR L))
Y (COMP0 (CADR L)))
(SETQ Y (MAKESAFE Y #(ILOCREG Y 1) () )))
() () 1)
(SETQ LX #(ILOCN X) LY (ILOC0 Y () ))
(AND (NOT (REGADP LX)) (PDERR (CONS FUN L) |Cant RPLAC numeric data|))
(AND #(PDLLOCP LX)
(EQ (CDR (CONTENTS LX)) 'IDUP)
(PROG2 ((LAMBDA (CNT) (DIDUP (LIST (CAR X)))) OCNT)
(SETQ LX (ILOC0 X () ))))
(COND ((AND (EQ FUN 'SETPLIST) ;Skip case of
(OR (NOT (EQ (CAR X) 'QUOTE)) (NULL (CADR X)))) ; (SETPLIST x '())
(REMOVEB X)
(SETQ OCNT (COND (#(ACLOCP LX) (CPUSH LX) LX)
((OR EFFS (DVP ARGNO)) #(FREAC))
('T ARGNO)))
(OUT1 'SKIPN OCNT LX)
#(OUTFS 'MOVEI OCNT 'NILPROPS)
(PUSH (SETQ X (LIST (GENSYM))) LDLST)
(CONT (SETQ LX OCNT) X)))
(COND ((QNILP Y) (OUT1 (GET FUN 'INSTN) 0 LX))
('T (SETQ LY #(ILOCREG Y (COND ((AND (NULL EFFS) ;This is just ILOCF
(AND (NUMBERP LX) (= LX 1))
(= ARGNO 1) ; except when result
(NULL VAL)) ; is to go into 1
#(FREAC))
('FRAC1))))
(AND (NOT #(ACLOCP LY)) (LOADAC Y (SETQ LY (FRAC1)) 'T))
(OUT1 (GET FUN 'INST) LY (ILOC0 X () ))))
(REMOVE X)
(REMOVE Y)
(CLEANUPSPL 'T) ;SO FORGET ABOUT ANY NASCENT CARCDRINGS
(RETURN (COND (VAL Y) (X)))))
(DEFUN COMSETQ (Y)
(PROG (LARG HOME V Z TEM NLP MODE LARGSLOTP DOD CMPVL SPFL NLARG)
COMSQ1
(SETQ MODE (AND (NOT (SETQ SPFL (SPECIALP (CAR Y)))) (VARMODE (CAR Y))))
(SETQ NLP (CDDR Y))
(SETQ HOME (ILOC0 (SETQ V (CONS (CAR Y) CNT)) MODE) TEM () )
(COND ((AND MODE
HOME
(SETQ TEM (NOT (ATOM (CADR Y))))
(SETQ Z (COND ((EQ (CAADR Y) 'ADD1) 'AOS)
((EQ (CAADR Y) 'SUB1) 'SOS)))
(AND (CDDR (CADR Y)) (NULL (CDDDR (CADR Y)))) ;LENGTH = 3
(EQ (CAR V) (CAR (CDDADR Y)))
(EQ (CADADR Y) 'FIXNUM)
(OR (NOT (ASSQ (CAR V) LDLST)) (NOT (DVP HOME)))
(NOT (REGADP HOME)))
(COND ((AND #(ACLOCP HOME) (CDR (CONTENTS HOME)))
(CPUSH1 HOME 'T () ) ;SLOTX has still been setup by CONTENTS
(RPLACA SLOTX () ) ; hence this becomes (CONT HOME () )
(SETQ HOME (ILOC2 'T V 'FIXNUM))))
(FREEZE-VAR (CAR V) '(REGACS () REGPDL 0) () 'T MODE) ;Remember, increments CNT
(ASIDE-FROM-FOO Z NLP HOME (CAR V) MODE) ;Z has INST, (CAR V) the var's name
(SETQ CNT (PLUS CNT 2))
(GO COMPS3)))
(COND ((AND TEM ;Prev value is
(SETQ TEM (CAADR Y)) ;(AND MODE HOME (NOT (ATOM (CADR Y))))
(MEMQ TEM '(PLUS TIMES DIFFERENCE *DIF))
(CDDDR (CADR Y)) ;Typical Y = (N (PLUS FIXNUM N FOO))
(NULL (CDDDDR (CADR Y))) ; Check length[cadr[y]] = 4
(CAR (SETQ Z (CDADR Y))) ;Z = (FIXNUM N FOO)
(ATOM (CAR Z))
(EQ (CAR Y) (CADR Z))
(SETQ Z (CADDR Z))
(COND ((NOT #(ACLOCP HOME)))
((EQ (CDR (CONTENTS HOME)) 'DUP)
(RPLACA SLOTX () ))
((ATOM Z) () )
((NOT (EQ (CAR Z) CARCDR)))))
(COND ((MEMQ TEM '(*DIF DIFFERENCE))
(SETQ TEM 'PLUS)
(SETQ Z (LIST 'MINUS (CADADR Y) Z))))
(SETQ Y (LIST (CAR Y) (LIST TEM (CADADR Y) Z (CAR Y))))))
(SETQ CMPVL (COMPR (CADR Y) MODE EFFS (NOT SPFL)))
(SETQ LARG (COND (MODE (COMLOCMODE CMPVL 'ARGNO MODE (CAR Y)))
('T #(ILOCREG CMPVL (COND (NLP 'FRACF) ('ARGNO))))))
(AND (OR SPFL (NOT MODE))
(SETQ TEM (MAKESURE (CADR Y) (CAR Y) SPFL CMPVL LARG))
(SETQ CMPVL TEM
LARG (COND ((EQ (CAR REGACS) CMPVL) 1)
((ILOC0 CMPVL () ))
((BARF CMPVL |Lost at makesure - COMSETQ|)))))
(AND (SETQ LARGSLOTP (NUMBERP LARG)) (SETQ NLARG LARG))
(COND ((AND SPFL
(SETQ TEM (ASSQ (CAR Y) LDLST))
(NOT (NUMBERP (ILOC0 TEM MODE))))
(OPUSHS (CAR Y))
(SETQ SPLDLST (DELQ TEM SPLDLST))
(AND LARGSLOTP
#(REGPDLP-N NLARG)
(SETQ NLARG (SETQ LARG (1- NLARG))))))
(REMOVEB CMPVL)
(COND ((AND MODE ;MODE=T => SPFL=()
LARGSLOTP
(NOT ATPL)
(AND (CDDDR LOUT) (NULL (CDDDDR LOUT))) ;LENGTH = 4
(SETQ TEM (GET (CAR LOUT) 'BOTH))
(NUMBERP (CADDR LOUT))
(= LARG (CADR LOUT))
(EQ (CADDDR LOUT) #(PDLAC MODE))
(EQUAL (SETQ Z (ILOC0 V MODE))
(CONVNUMLOC (CADDR LOUT) MODE))
(NOT (DVP (CADR LOUT)))
(OR (NOT (ASSQ (CAR Y) LDLST)) (NOT (DVP Z))))
(CONT (CADR LOUT) (CONS (CAR Y) 'DUP))
(RPLACA LOUT TEM)
(FREEZE-VAR (CAR V) '(REGACS () REGPDL 0) () 'T MODE)
(SETQ CNT (1+ CNT))
(GO COMPS3)))
(SETQ V (CAR Y))
; So freeze world at this point
(SETQ TEM (FREEZE-VAR V
'(REGACS () NUMACS () REGPDL 0 FXPDL ##(FXP0) FLPDL ##(FLP0))
(CAR CMPVL)
()
MODE))
(AND LARGSLOTP #(PDLLOCP-N NLARG)
(SETQ LARGSLOTP (NUMBERP (SETQ LARG (ILOC2 (VARBP (CAR CMPVL))
CMPVL
(GETMODE LARG)))))
(SETQ NLARG LARG))
(SETQ DOD (AND LARGSLOTP (DVP LARG)))
(SETQ HOME
(COND (SPFL) ;HOME = () =>
((NULL TEM) () ) ;Local var without home on PDL
((NOT (DVP4 (CAAR TEM) (CDR TEM))) ; or else locvar with DVP home
(CDR TEM)))) ;HOME = non-null =>
; can store into old homeloc
(SETQ CNT (1+ CNT))
(COND ((AND (OR EFFS NLP) (NOT HOME) (OR MODE (REGADP LARG)))
(SETQ V (LIST V))
(COND ((AND LARGSLOTP (NOT DOD))
(COND ((AND MODE #(REGADP-N NLARG)) (OPUSH LARG V MODE))
('T (CONT LARG V))))
('T (OPUSH LARG V MODE)))
(GO COMPS3)))
(COND ((AND HOME
(COND (MODE (Q0P+0P (CADR Y)))
('T (QNILP (CADR Y)))))
(ASIDE-FROM-FOO 'SETZM NLP HOME V MODE)
(GO COMPS3)))
(COND ((COND ((NOT DOD) () )
((NOT (NUMBERP LARG)) () )
(MODE #(NUMACP-N NLARG))
('T #(REGACP-N NLARG)))
(CPUSH LARG))
((AND (NULL MODE) LARGSLOTP #(NUMACP-N NLARG))
(AND DOD (CPUSH LARG))
(PUSH (SETQ CMPVL (CONS (CAR CMPVL) CNT)) LDLST)
(SETQ LARG (COND ((AND (NOT EFFS) (NULL NLP) (NOT #(NUMACP-N ARGNO)))
ARGNO)
((FRAC1))))
(MAKEPDLNUM CMPVL LARG))
((OR (NOT LARGSLOTP)
DOD
(MINUSP LARG)
(DVP LARG)
(AND MODE (REGADP LARG)))
(LOADAC CMPVL (SETQ LARG (COND ((AND (NOT EFFS) (NULL NLP))
(COND ((NOT #(NUMACP-N ARGNO))
(COND (MODE #(NUMVALAC)) (ARGNO)))
(MODE ARGNO)
((FRAC5))))
(MODE (FREENUMAC))
((FRAC5))))
())))
(CONT LARG (LIST V))
(COND (SPFL
(COND ((REGADP LARG)
(COND ((ZEROP LARG) (OPOP SPFL () ))
('T #(OUTFS 'MOVEM LARG SPFL))))
('T (BARF (LIST V LARG) |Special set from ? - COMSETQ|)))))
COMPS3
(COND (NLP (SETQ Y NLP) (GO COMSQ1))
((NULL EFFS)
(SETQ V (CONS (CAR Y) CNT))
(AND SPFL (SETQ SPLDLST (CONS V SPLDLST)))
(RETURN V)))))
;;; PUTS OUT THINGS LIKE (SETZ 0 (SPECIAL FOO)) (SETZB 7 -3 FXP)
;;; (AOS 0 11) (SOS 7 0 FXP)
(DEFUN ASIDE-FROM-FOO (INST NLP HOME V MODE) ;CALLED ONLY FROM COMSETQ
((LAMBDA (AC)
(OUT1 (COND ((OR NLP EFFS) INST)
('T (SETQ AC (COND (MODE (FREENUMAC))
((NOT (DVP ARGNO)) ARGNO)
((NOT (ZEROP (SETQ AC (FRACB)))) AC)
('T (CPUSH ARGNO) ARGNO)))
(COND ((EQ INST 'SETZM) 'SETZB) (INST))))
AC
(COND ((NUMBERP HOME) (CONT HOME (LIST V)) HOME)
(HOME))) ;Should be (SPECIAL foo)
(AND (NOT (ZEROP AC)) (CONT AC (CONS V (COND ((NUMBERP HOME) 'DUP)))))
() )
0))
(DEFUN FREEZE-VAR (V L ITEM OEFFS MODE)
((LAMBDA (OHOME HOME II N)
(SETQ V (CONS V (SETQ CNT (1+ CNT))))
(DO ZZ L (CDDR ZZ) (NULL ZZ)
(DO ((Z (SYMEVAL (CAR ZZ)) (CDR Z)) (I 0 (1+ I)) (PDLP (CADR ZZ)))
((NULL Z))
(AND (CAR Z)
(EQ (CAAR Z) (CAR V))
(COND ((MEMQ (CDAR Z) '(() OHOME))
(COND ((NULL PDLP) (RPLACA Z V))
((AND (NULL (CDAR Z)) (NULL HOME))
(SETQ HOME Z II (- PDLP I)))
((AND (EQ (CDAR Z) 'OHOME) (NULL OHOME))
(SETQ OHOME Z N (- PDLP I)))
((BARF () |King of confusion - FREEZE-VAR|))))
((MEMQ (CDAR Z) '(DUP IDUP)) (RPLACD (CAR Z) (1- CNT)))))))
(AND HOME (RPLACA HOME V))
(COND (OHOME
(COND ((DVP4 (CAR OHOME) N)
(OPUSH N
(CONS (CAR V) (GET (CAR V) 'OHOME))
MODE)
(AND HOME
(NOT OEFFS)
(EQ (GETMODE N) (GETMODE II))
(SETQ II (1- II)))))
(PUTPROP (CAR V) CNT 'OHOME))
(HOME
(COND ((DVP4 (CAR HOME) II)
(OPUSH II V MODE)
(SETQ II (1- II))))
(PUTPROP (CAR V) CNT 'OHOME)
(RPLACA HOME (CONS (CAR V) 'OHOME))))
(CARCDR-FREEZE (CAR V) ITEM)
(AND (NOT OEFFS) HOME (CONS HOME II)))
() () 0 0))
(DEFUN COMTP (EXP INST TAG F VALUEP) ;Compile for "TYPEP"
#(LET ((ARGNO (COND (VALUEP ARGNO) ((FRAC1)))))
(PROG (TEM LOC AC ACP) ; and similar functions
(SETQ AC 0) ;Table index for that type datum
(SETQ LOC #(ILOCN (SETQ TEM (COMP (CADR EXP))))) ; into some free NUMAC, which is returned
(REMOVE TEM) ; [except for case of "ATOM"]
(AND VALUEP ;If no TAG, then for value
(CPUSH-DDLPDLP ARGNO LOC)
(SETQ LOC (1- LOC)))
(COND ((COND ((NUMBERP LOC) (SETQ TEM (GETMODE LOC))) ;If quantity is known to be
((AND (NULL (CDR LOC))
(MEMQ (SETQ TEM (TYPEP (CADAR LOC)))
'(FIXNUM FLONUM)))))
(SETQ LOC (COND ((EQ (CAR EXP) 'TYPEP) TEM) ; either FIXNUM or FLONUM
((MEMQ (CAR EXP) '(ATOM NUMBERP)) 'T) ; then return that instead
((EQ (CAR EXP) 'BIGP) () ) ; of compiling code for getting
((MEMQ (CAR EXP) '(FIXP FLOATP)) ;the type bits into a NUMAC
#(EQUIV (EQ (CAR EXP) 'FIXP)
(EQ TEM 'FIXNUM)))))
(SETQ TEM #(EQUIV LOC F)) ;Match the type of cadr[exp]
(COND (TAG (AND TEM (PROG2 (CLEARVARS) (OJRST TAG 0)))) ;predicates - but not "TYPEP"
((OUTPUT (COND ((NULL INST) (LIST 'MOVEI ARGNO (LIST 'QUOTE LOC)))
(#(EQUIV LOC F) (BOLA ARGNO 2))
('T (BOLA ARGNO 5) )))))
(RETURN 'T)))
(COND (#(ACLOCP LOC)
(CPUSH LOC)
(CONT LOC () )
(SETQ AC LOC ACP 'T)))
(COND ((EQ (CAR EXP) 'TYPEP)
(AND (OR EFFS #(NUMACP-N ARGNO)) (BARF () |Sumpins wrong - COMTP|))
(OUT1 'SKIPN
(COND ((NULL ACP) (SETQ AC ARGNO) ARGNO)
(0))
LOC)
(OUTPUT (BOLA AC 2)) ;MOVEI ARGNO,'T
#(OUTFS 'LSH AC -9.) ; ### since ()=NIL is SYMBOL
(CONT AC () )
(OUTPUT (CONS 'HRRZ (CONS ARGNO (CDR (STGET AC)))))
(RETURN () )))
(COND ((NULL ACP) (SETQ AC (FREENUMAC)) (OUT1 'MOVE AC LOC)))
(COND (TAG (CLEARVARS) (RSTD TAG AC 0)))
(COND ((EQ (CAR EXP) 'ATOM)
#(OUTFS 'LSH AC -9.)
(CONT AC () )
(SETQ INST (COND (#(EQUIV F TAG) 'SKIPL) ('SKIPGE)))
(OUTPUT (CONS INST (STGET AC)))
(COND (TAG (OUTJ0 'JUMPA 0 TAG 'T 0)) ;Like OJRST, but no
(VALUEP (BOOLOUT () () )))) ; subsequent deletions
('T (PROG (VTAG)
(COND ((NOT (EQ (CAR EXP) 'SYMBOLP)))
((AND TAG F) (OUTJ 'JUMPE AC TAG))
((AND F (NULL TAG) (NULL VALUEP))
(OUTPUT (BOLA AC 6)) ;SKIPN 0 ac
(OUTPUT (BOLA AC 2))) ;MOVEI ac,'T
('T #(OUTFS 'JUMPE AC (SETQ VTAG (GENSYM))) ))
#(OUTFS 'LSH AC -9.)
(CONT AC () )
(SETQ TEM (CDR (STGET AC)))
(COND ((NOT #(NUMACP-N AC))
(SETQ AC (FREENUMAC))
(RPLACA SLOTX () ))) ;(CONT AC () )
(OUTPUT (CONS 'MOVE (CONS AC TEM)))
(SETQ INST (COND (F (CAR INST)) ((CDR INST))))
(COND (TAG (OUTJ INST AC TAG)
(AND VTAG (OUTPUT VTAG)))
('T #(OUTFS (CAR INST) AC (CDR INST))
(AND VTAG (NULL F) (OUTPUT VTAG))
(AND VALUEP (BOOLOUT (AND F VTAG) () ))))))) )))
;;; This compilation critically depends on the subr for NUMBERP leaving a
;;; numerical value in accumulatr TT with the correct algebraic sign.
(DEFUN COMSIGNP (EXP TAG F)
((LAMBDA (INST)
(AND (NULL INST)
(SETQ INST '(- . JUMP))
(PDERR (CAR EXP) |Wrong type arg to SIGNP|))
(LOADAC (COMP1 (CADR EXP)) 1 () )
(CPUSH #(NUMVALAC))
(RPLACA SLOTX () ) ;(CONT #(NUMVALAC) () )
(RPLACA ACSMODE () ) ;(SETMODE #(NUMVALAC) () )
(OUTPUT '(CALL 1 'NUMBERP))
(COND ((COND ((NULL TAG))
(F (CLEARVARS) (RSTD TAG 1 0) 'T))
(OUTPUT '(SKIPE 0 1)))
('T (CLEARVARS) (OUTJ0 'JUMPE 1 TAG () 1)))
(SETQ INST (COND ((OR F (NULL TAG)) (CDR INST))
((GET (CDR INST) 'CONV))))
(RPLACA REGACS () ) ;(CONT 1 () )
(COND (TAG (OUTJ0 INST 'TT TAG 'T 0))
('T #(OUTFS INST 'TT '(* 2))
(OUTPUT '(MOVEI 1 '() )))))
(ASSQ (CAR EXP)
'((L . JUMPL) (E . JUMPE) (LE . JUMPLE)
(GE . JUMPGE) (N . JUMPN) (G . JUMPG)))))
(DEFUN COMZP (EXP TAG F)
((LAMBDA (Z INST NODDP)
(SETQ INST (COND (TAG (CAR INST)) ((CDR INST))))
(AND (NOT F) (SETQ INST (GET INST 'CONV)))
(COND (TAG (OUTJ (COND (NODDP INST)
;((ASSQ INST '((TRNN . 1) (TRNE . 1))))
((EQ INST 'TRNN) '(TRNN . 1))
((EQ INST 'TRNE) '(TRNE . 1)))
(LOADINSOMENUMAC Z)
TAG))
((NOT NODDP)
(SETQ NODDP (LOADINSOMENUMAC Z))
(CPUSH ARGNO)
#(OUTFS INST NODDP '1))
('T (SETQ NODDP #(ILOCF Z))
(REMOVE Z)
(COND (#(ACLOCP NODDP) (CPUSH NODDP) (CPUSH ARGNO))
((CPUSH-DDLPDLP ARGNO NODDP) (SETQ NODDP (1- NODDP))))
(OUT3 (ASSQ INST '((SKIPE) (SKIPG) (SKIPL) (SKIPN) (SKIPLE) (SKIPGE)))
0
NODDP))))
(COMPW (CADDR EXP) () (FREENUMAC))
(CDR (ASSQ (CAR EXP) '((ZEROP . (JUMPE . SKIPE))
(PLUSP . (JUMPG . SKIPG))
(MINUSP . (JUMPL . SKIPL))
(ODDP . (TRNN . TRNN)))))
(NOT (EQ (CAR EXP) 'ODDP))))
(COMMENT AUXILIARY FUNCTIONS)
(DEFUN 1FREE () (NOT (DVP1 REGACS 1)))
(DEFUN 1INSP (VAR)
(COND (#(NUMACP-N ARGNO)) ;Tries to figure out if a varialbe is LOADAC-able
(((LAMBDA (MODE) ; in only one instruction; rets CLPROGN if on NUMPDL
(COND ((NULL MODE) (OR CONDPNOB (NOT (MEMQ VAR UNSFLST))))
((NULL CONDPNOB) () )
((CLMEMBER VAR () #(PDLGET MODE) 'EQ) CLPROGN)))
(VARMODE VAR)))))
(DEFUN 6BSTR (X)
(AND (NOT (SYMBOLP X)) (SETQ X (MAKNAM (EXPLODEN X))))
(DO ((I 1 (1+ I)) (N 0) (ZZ () (CONS N ZZ)))
((ZEROP (SETQ N (GETCHARN X I))) (MAKNAM (NRECONC ZZ '(/!))))
(COND ((OR (= N 35.) (= N 94.) (= N 33.)) (SETQ ZZ (CONS '/# ZZ))) ;CHECK FOR # ↑ !
((LESSP 31. N 96.)) ;VALID SIXBIT
('T (SETQ ZZ (CONS '/↑ ZZ)) ;ELSE CONTROLIFY
(AND (= N 13.) (= (GETCHARN X (1+ I)) 10.) (SETQ I (1+ I)))
(SETQ N (BOOLE 6 N 64.))))))
(DEFUN ACSMRGL (X) (ACMRG REGACS NUMACS ACSMODE (CAR X) (CADR X) (CADDR X) () ))
(DEFUN ACMRG (LL ZZ MM L Z M F)
; Merge ACCs off L onto LL if F = (),
; set LL from L if F = T
(DO ((LL LL (CDR LL))
(L L (CDR L))
(N #(NACS) (SUB1 N)))
((ZEROP N))
(COND (F (RPLACA LL (CAR L)))
((NULL (CAR LL)))
((NOT (EQUAL (CAR LL) (CAR L))) (RPLACA LL () ))))
(DO ((A1 MM (CDR A1))
(A2 M (CDR A2))
(N #(NUMNACS) (SUB1 N))
(LL ZZ (CDR LL))
(L Z (CDR L)))
((ZEROP N))
(COND (F (RPLACA LL (CAR L)) (RPLACA A1 (CAR A2)))
((NULL (CAR LL)))
((NOT (EQUAL (CAR LL) (CAR L)))
(RPLACA LL () )
(RPLACA A1 () )))))
(DEFUN ADD (X Y) (COND ((MEMQ X Y) Y) ('T (CONS X Y))))
(DEFUN ADR (X)
(CDR (COND ((NULL X) '(() . () ))
((ASSQ X GL))
('T '(() . () )))))
(DEFUN ASQSLT (X) (OR (ASSQ X REGACS) (ASSQ X REGPDL) (ASSQ X NUMACS)
(ASSQ X FXPDL) (ASSQ X FLPDL)))
(DEFUN ASSOCR (X Y)
(DO Y Y (CDR Y) (NULL Y) (COND ((EQ X (CDAR Y)) (RETURN Y)))))
(DEFUN BADTAGP (TAG)
((LAMBDA (TEM)
(OR (NOT (EQ (L/.LE/. REGPDL (CAR TEM)) 'EQUAL))
(NOT (EQ (L/.LE/. FXPDL (CADR TEM)) 'EQUAL))
(NOT (EQ (L/.LE/. FLPDL (CADDR TEM)) 'EQUAL))))
(CDDDR (LEVEL TAG))))
(DEFUN BOOL1 (EXP TAG F)
; Compile general boolean form, JRST to TAG when result
; matches F, otherwise drop through
; Return non-null only when unconditional JRST taken
(PROG (PROP)
(SETQ PROP (AND (SYMBOLP (CAR EXP)) (GET (CAR EXP) 'P1BOOL1ABLE)))
A (COND ((EQ PROP 'T)
(COND ((COND ((EQ (CAR EXP) 'AND)
(BOOL2 (CDR EXP) TAG F 'T)
'T)
((EQ (CAR EXP) 'OR)
(BOOL2 (CDR EXP) TAG (NOT F) () )
'T))
(SETQ CNT (PLUS CNT 2)))
((EQ (CAR EXP) 'NULL) (RETURN (BOOL1 (CADR EXP) TAG (NOT F))))
((EQ (CAR EXP) 'COND) (COMCOND (CDR EXP) TAG F () ))
((EQ (CAR EXP) 'EQ) (COMEQ (CDR EXP) TAG F))
((EQ (CAR EXP) 'MEMQ)
(AND F (RETURN (BOOL3 EXP 'T TAG F))) ;CLOSE-CALL, AND JUMPN
((LAMBDA (X Y LX ARGNO A1 A2 EFFS OEFFS)
(DECLARE (FIXNUM A1 A2))
(SETQ X (COMP0 (CADR EXP)) Y (COMP0 (CADDR EXP)))
(SETQ EFFS OEFFS)
(SETQ LX #(ILOCF X))
(SETQ A1 (LOADINREGAC Y () () ))
(CLEARVARS)
(CONT A1 '(NIL . TAKEN))
(CONT (SETQ A2 #(FREACB)) () )
(OUTJ0 'JUMPE A1 TAG () A2)
(AND (NOT (REGADP LX))
(DBARF EXP |Numeric 1st arg to MEMQ?| 4 6))
(AND (NUMBERP LX)
(NOT (EQUAL X (CONTENTS LX)))
(SETQ LX (ILOC0 X () )))
(REMOVEB X)
(OUT1 '(HLRZ) A2 A1)
(OUT1 '(HRRZ) A1 A1)
(OUT1 'CAME A2 LX)
(OUTPUT '(JUMPA 0 (* -4)))
(CONT A1 () )
A1)
() () () 1 0 0 () EFFS))
((EQ (CAR EXP) 'SIGNP) (COMSIGNP (CDR EXP) TAG F))
((BARF () |Lost dispatch in BOOL1|))))
((NULL PROP)
(COND ((AND (EQ (CAR EXP) 'PROG2) (NULL (CDDDR EXP)))
(COMPE (CADR EXP))
(RST TAG)
(RETURN (BOOL1 (CADDR EXP) TAG F)))
((RETURN (BOOL3 EXP 'T TAG F)))))
((EQ PROP 'NUMBERP)
(COND ((COND (CLOSED (NOT (MEMQ (CADR EXP) '(FIXNUM FLONUM))))
('T (NOT #(KNOW-ALL-TYPES (CADR EXP)))))
(RETURN (BOOL3 EXP 'T TAG F)))
((MEMQ (CAR EXP) '(GREATERP LESSP)) (COMGRTLSP EXP TAG F))
((EQ (CAR EXP) 'EQUAL) (COMEQ (CDR EXP) TAG F))
((MEMQ (CAR EXP) '(ZEROP PLUSP MINUSP ODDP))
(COMZP EXP TAG F))
((BARF EXP |Is this really P1BOOL1ABLE?|))))
((NOT (ATOM PROP)) (COMTP EXP PROP TAG F () ))
('T (SETQ PROP 'NUMBERP) (GO A)))))
(DEFUN BOOL1LCK (EXP TAG F)
((LAMBDA (T1)
(COND (T1 (BOOL1 EXP (SETQ T1 (LEVELTAG)) (NOT F))
(OJRST TAG () )
(OUTTAG-TO-LEVEL T1))
('T (BOOL1 EXP TAG F))))
(BADTAGP TAG)))
(DEFUN BOOL2 (EXP TAG F ANDFL)
; COMPILE AND OR
(COND (F (COND ((CDR (SETQ EXP (L2F (CDDDDR EXP))))
(BOOL2LOOP (CDR EXP) (SETQ F (LEVELTAG)) (NOT ANDFL)))
('T (SETQ F () )))
(BOOL1 (CAR EXP) TAG ANDFL)
(OUTTAG F))
('T (BOOL2LOOP (CDDDDR EXP) TAG (NOT ANDFL)))))
(DEFUN BOOL2LOOP (EXP BTAG B2F) (MAPC '(LAMBDA (EXP) (BOOL1 EXP BTAG B2F)) EXP))
(DEFUN BOOL3 (EXP FLAG TAG F)
(PROG (Z LARG LARGSLOTP FL MODE)
(SETQ Z (COND (FLAG (COMPR EXP () 'T 'T)) (EXP)))
(SETQ LARG #(ILOCF Z))
(SETQ LARGSLOTP (NUMBERP LARG))
(AND LARGSLOTP (SETQ MODE (GETMODE LARG)))
(COND ((AND (NOT LARGSLOTP) (EQ (CAAR LARG) 'QUOTE))
(REMOVE Z)
(COND (#(EQUIV (CADAR LARG) F)
(CLEARVARS)
(OJRST TAG () )
(RETURN 'T))
('T (RETURN () )))))
(COND ((NOT (REGADP LARG)) (REMOVE Z) (CLEARVARS)
(RETURN (COND (F (OJRST TAG () ) 'T)))))
(SETQ FL (RST TAG))
(REMOVE Z)
(AND (OR (CLEARVARS) FL)
LARGSLOTP
(NOT (PLUSP LARG))
(SETQ LARG (ILOC0 Z MODE)))
(OUTJ0 (COND (F 'JUMPN) ('JUMPE)) LARG TAG () LARG)
(RETURN () )))
(DEFUN BOOLOUT (TAG FL)
(COND ((NOT (LESSP 0 ARGNO #(NUMVALAC)))
(WARN () |Predicate in numerical argument position|)
(OUTPUT (SUBST ARGNO 'ARGNO '(MOVEI ARGNO 0))))
(((LAMBDA (TEM)
(OUTPUT TEM)
(AND TAG
(COND (FL (AND (OUTTAG TAG)
(NOT (EQ LOUT1 TEM))
(BARF TAG |Lost in BOOLOUT|)))
('T (OUTPUT TAG))))
(OUTPUT (BOLA ARGNO 2))
(|Oh, FOO!|))
(BOLA ARGNO 1) ))))
(DEFUN CARCDR (ITEM ACORFUN) ;Computes a CARCDR
;;; Compilation - returns SLOTLIST number of resultant
;;; Typical item is (G0025 (D A D D) X . 5) for (CDDADR X)
;;; If item is (G0025 (CARCDR-FREEZE A D A D . . .) X . 5),
;;; then no VL crossings may be made to link to it
(PROG (AC T1 2LONG T2 LT2 ACP N MATCHP TEM FL)
(SETQ ACP (NUMBERP ACORFUN))
(SETQ LT2 #(ILOCREG (SETQ T2 (CDDR ITEM))
(COND ((AND ACP
(SETQ N ACORFUN)
#(REGACP-N N))
ACORFUN)
((FRAC)))))
(REMOVE T2)
(SETQ N 0 T1 (CADR ITEM))
(AND (EQ (CAR T1) 'CARCDR-FREEZE) (SETQ T1 (CDR T1)))
(COND ((AND (ATOM (CAR T2))
(VARBP (CAR T2))
(DO ((ZZ SPLDLST (CDR ZZ)) (2LONG-SETP)) ;Look for (GN (A . .) X.5)
((NULL ZZ) MATCHP)
(AND (CAR ZZ)
(NOT (EQ ITEM (CAR ZZ)))
(NOT (ATOM (CDAR ZZ))) ; found (GM . .)
(EQ (CADDAR ZZ) (CAR T2)) ; found (GM . . X.7)
(EQ (CAADAR ZZ) (CAR T1)) ; found (GM (A . .) X.7)
(COND (2LONG-SETP) ;Setup the variable 2LONG
(ACP (SETQ 2LONG #(NUMACP ACORFUN)
2LONG-SETP 'T))
((SETQ 2LONG (COND ((EQ ACORFUN 'FREENUMAC))
((EQ ACORFUN 'ARGNO)
#(NUMACP-N ARGNO)))
2LONG-SETP 'T)))
(COND (2LONG (ASQSLT (CAAR ZZ))) ;2LONG is switch to tell
((ASSQ (CAAR ZZ) REGACS)) ; whether or not to look
((ASSQ (CAAR ZZ) REGPDL))) ; everywhere for possibilities
(EQUAL (ILOC0 (CDDAR ZZ) () ) LT2) ;X.5 can be used for X.7
(PROG (L LL)
(SETQ L T1) ;T1- open string of ITEM
(SETQ LL (CADAR ZZ)) ;LL - open string of candidate
(AND (< (LENGTH LL) N) (RETURN () ))
A (COND ((NOT (EQ (CAR L) (CAR LL))) (RETURN () ))
((SETQ LL (CDR LL))
(COND ((SETQ L (CDR L)) (GO A))
((RETURN () )))))
;Candidate is an initial substring of ITEM
(SETQ MATCHP (CAR ZZ) N (LENGTH (CADR MATCHP)))))))
(COND ((EQUAL (CADR MATCHP) T1)
(PUSH (CONS (CAR MATCHP) (CAR ITEM)) VL)
(RETURN (ILOCMODE MATCHP () '(FIXNUM FLONUM))))
('T (SETQ T2 (LIST (GENSYM))
T1 #(NCDR T1 N)
LT2 (ILOCMODE MATCHP () '(FIXNUM FLONUM)))
(PUSH (CONS (CAR MATCHP) (CAR T2)) VL)))))
(SETQ 2LONG (CDDDR T1))
(SETQ AC (COND ((NOT ACP)
(COND ((AND 2LONG (OR (EQUAL LT2 1) (1FREE)))
1)
('T ((LAMBDA (LDLST LL)
(COND (2LONG (CC0 (FRAC)))
((EQ ACORFUN 'FRACF) (FRACF))
((EQ ACORFUN 'FREENUMAC) (FREENUMAC))
((EQ ACORFUN 'ARGNO)
(COND ((AND (NOT EFFS)
(= ARGNO 1)
(PROG2 (SETQ LDLST LL)
(DVP1 REGACS 1)
(SETQ LDLST TEM)))
(CC0 (FRAC)))
((OR EFFS #(NUMACP-N ARGNO)) (FRACF))
(ARGNO)))
((BARF ACORFUN |? fun - CARCDR|))))
(SETQ TEM (CONS T2 LDLST)) LDLST))))
((OR (NOT 2LONG) (= ACORFUN 1)) ACORFUN)
((OR (EQUAL LT2 1) (1FREE)) 1)
((AND (CDDR 2LONG) (NOT (ZEROP (SETQ N (FRAC))))) (CC0 N))
('T ACORFUN)))
(SETQ TEM (COND ((AND #(PDLLOCP LT2) (NOT #(NUMACP-N AC)))
;LT2 must always be a REGADP. Thus if it is a PLDLOCP, it is the REGPDL
; and if AC is a REGAC, then a CPUSH might change the REGPDL
(SETQ FL 'T)
(AND (NULL TEM) (SETQ TEM (CONS T2 LDLST)))
((LAMBDA (LDLST) (CPUSH AC)) TEM)) ;Ordinarily, a semipush would be needed
('T (SETQ FL () ) (CPUSH AC)))) ; but the LDLST prevents trouble here
;;; Losing T2 may have moved around by CC0 or CPUSH
(COND ((OR (NOT ACP) (AND TEM FL))
(SETQ LT2 (ILOC0 T2 () ))))
(SETQ FL () ACP #(ACLOCP LT2) MATCHP () )
B (COND ((AND ACP (= LT2 1) (= AC 1) (CDDR T1))
;ACP now applies to LT2, which is place to start [or continue] CARCDRing from
;T1 contains D-A list of directions, and this clause is taken if 3 or more.
;FL=T => We have a private copy of current portion of T1
(AND (NULL FL) (SETQ FL (SETQ T1 (APPEND T1 () ))))
(COND ((CDDDDR T1)
(AND (NOT MATCHP) (SETQ MATCHP 'T) (CLEARNUMACS))
;If more than 4, then bite of a chunk of 4, feed TO CCOUT, and carry on
(CCOUT (PROG2 () T1 (RPLACD (SETQ T1 (CDDDR T1))
(PROG2 (POP T1) () ))))
(GO B))
((CCOUT T1))))
('T (AND (AND (NOT ATPL) (NOT ATPL1))
(EQ (CAR LOUT) 'MOVE) ;If LOUT = (MOVE AC 0 AC)
(MEMQ (CAR LOUT1) '(HRRZ HLRZ))
(NUMBERP (CADR LOUT))
(SIGNP E (CADDR LOUT)) ; and LOUT1 had just loaded AC
(NUMBERP (CADDDR LOUT))
(= (CADR LOUT) AC) ; then flush LOUT
(= (CADDDR LOUT) AC)
(EQUAL (CADR LOUT1) AC)
(SETQ LOUT (SETQ ATPL 'FOO)))
(OUT1 (GET (CAR T1) 'INST) AC LT2)
(POP T1)
(COND (T1 (SETQ LT2 AC ACP 'T) (GO B)))))
(CONT (SETQ N AC) (LIST (CAR ITEM)))
(COND ((COND (#(NUMACP-N AC))
((EQ ACORFUN 'FREENUMAC)
(SETQ TEM (CAR SLOTX) AC (FREENUMAC))
(RPLACA SLOTX TEM) ;Quick way of (CONT N (CONTENTS AC))
'T))
(SETMODE AC () )
(OUT1 '(MOVE) AC N)))
(RETURN AC) ))
(DEFUN CCOUT (X) ;(D A D D) => (CALL 1 'CDDADR)
((LAMBDA (FUN)
#(OUTFS 'JSP
'T
(LIST 'CARCDR (CDDR (GET FUN 'CARCDR)))
0
FUN))
(IMPLODE (CONS 'C (NRECONC X '(R))))))
(DEFUN CC0 (AC)
;;; Should be called only when (DVP (CONTENTS 1)) also, (FRAC) leaves SLOTX set
(COND ((ZEROP AC) (CPUSH1 1 () () ))
((= AC 1))
((CCSWITCH AC 1)) ;If CCSWITCH is (), the SLOTX is undisturbed
('T (RPLACA SLOTX (CAR REGACS)) ;(CONT AC (CONTENTS 1))
(RPLACA REGACS ;(CONT 1 (CONS (CAAR (CONTENTS 1)) 'DUP))
(CONS (CAAR REGACS) 'DUP))))
1)
(DEFUN CCSWITCH (A1 A2) ;A1 is always a REGAC address
(COND ((AND (NOT ATPL)
(MEMQ (CAR LOUT) '(MOVE HRRZ HLRZ MOVEI))
(NUMBERP A2)
(NUMBERP (CADR LOUT))
(= (CADR LOUT) A2))
(OUTPUT (PROG2 ()
(CONS (CAR LOUT) (CONS A1 (CDDR LOUT)))
(SETQ LOUT (SETQ ATPL 'FOO))))
(SETQ A1 (FIND A1) A2 (FIND A2)) ;This might move CARCDRs ITEM
(RPLACA A1 (CAR A2)) ;(CONT A1 (CONTENTS A2))
(RPLACA A2 () ) ;(CONT A2 () )
'T)
('T (OUT1 'MOVE A1 A2)
() )))
;;; If first arg is null, then freez-out all carcdr-ings that are still around
;;; If second arg is null, then freeze-out all carcdr-ings over the variable
;;; indicated by the first arg.
(DEFUN CARCDR-FREEZE (V ITEM)
((LAMBDA (FL)
(MAP '(LAMBDA (LL)
(COND ((NULL (CAR LL)) (SETQ FL () ))
((OR (ATOM (CDAR LL))
(AND V (NOT (EQ (CADDAR LL) V)))))
((OR (ASSQ (CAAR LL) LDLST) (DVP3 (CAAR LL) VL) (AND ITEM (EQ (CAAR LL) ITEM)))
(AND (NOT (EQ (CAADAR LL) 'CARCDR-FREEZE)) ;Modify the SPLDLST so that
(RPLACA LL (CONS (CAAR LL) ;no VL crossings can use this
(CONS (CONS 'CARCDR-FREEZE (CADAR LL))
(CDDAR LL))))))
('T (CLOBBER-SLOT (CAR LL) REGACS)
(CLOBBER-SLOT (CAR LL) REGPDL)
(RPLACA LL (SETQ FL () ))))) ;Remove this loser from SPLDLST
SPLDLST)
(AND (NULL FL) (FLUSH-SPL-NILS)))
'T))
(DEFUN CLEAR (Y CLBFL)
; Clear up the status of things that might get clobbeed in a COND, PROG, LAMBDA [or LSUBR aplication]
; PROGN on Y ==> Unknown-function-application in form
; NULFU on Y ==> RPLACA-D in form
; GOFOO on Y ==> GO or RETURN in form
; Variable X ==> (SETQ X FOO) in form
(AND Y
(PROG (L MODE Z PDL)
(SETQ L (MAPCAN
'(LAMBDA (X)
(COND ((OR (EQ X GOFOO) (EQ X NULFU) (EQ X PROGN) (SPECIALP X))
() )
('T
(SETQ MODE (VARMODE X) PDL #(PDLGET MODE))
(COND ((AND MODE
(COND ((SETQ L (CLMEMBER X () REGPDL 'EQ))
(SETQ Z (- (LENGTH L) (LENGTH REGPDL)))
'T)
((SETQ L (CLMEMBER X () REGACS 'EQ))
(SETQ Z (- (1+ #(NACS)) (LENGTH L)))
'T)))
; Dont let local numvars be homed in the regworld
(OPUSH Z (CAR L) MODE)
(RPLACA L (CONS X CNT))
(SETQ L PDL))
('T (SETQ L (CLMEMBER X () PDL 'EQ))))
(COND ((OR (NULL L) (NULL (SETQ PDL (CLMEMBER X 'OHOME PDL 'EQ))))
() )
('T (LIST (LIST X MODE L PDL)))))))
Y))
; L is a list of losers that have both valid homes and ohomes on the PDL
A (COND ((NULL L) (GO C))
((OR (SETQ Z (CLCHK (SETQ PDL REGPDL) L))
(SETQ Z (CLCHK (SETQ PDL FXPDL) L))
(SETQ Z (CLCHK (SETQ PDL FLPDL) L)))
(SETQ L (DELQ Z L) MODE (CADR Z))
(RPLACA (CADDDR Z) (CAR PDL))
(OPOP (CLLOC (CADDDR Z) MODE) MODE)
(GO A)))
B (COND ((SETQ MODE (CADAR L)) (SETQ Z (FREENUMAC)))
('T (SETQ Z (FRAC5)))) ;SLOTX left set by FREAC
(SETQ PDL (CADDAR L))
(OUT1 'MOVE Z (CLLOC PDL MODE))
(RPLACA SLOTX (CAR PDL))
(RPLACA PDL () )
(CPUSH1 Z () () ) ;SLOTX still set
(POP L)
(GO A)
C (COND ((MEMQ GOFOO Y) (SETQ CLBFL 'T) (CPVRL)) ;Make sure relevant PROG
((AND PVRL (NULL LPRSL)) (CNPUSH (LAND PVRL Y) () ))) ;vars have a home
;;; Ditto for LAMBDA variables
(AND OLVRL (CNPUSH (LAND OLVRL Y) () ))
;;; Push out delayed SPECIALs or CARCDRs that might be clobbered
(AND LDLST
(COND ((MEMQ PROGN Y) (CSLD 'T 'T Y))
('T (CSLD () (MEMQ NULFU Y) Y))))))
;;; Depending on input, we flush out the acs
(AND CLBFL (CLEARACS0 () )))
(DEFUN CLEARACS (N CLBFL HOME)
(DECLARE (FIXNUM MODEFL))
(PROG (I FL MODEFL)
A (COND ((MINUSP N)
(SETQ SLOTX NUMACS) (SETQ I #(NUMVALAC))
(SETQ MODEFL (SETQ N (- #(NUMVALAC) 1 N))))
((SETQ SLOTX REGACS) (SETQ I 1) (SETQ MODEFL 0)))
B (COND ((EQ (CPUSH1 I HOME () ) 'PUSH) (SETQ FL 'T)))
(AND CLBFL (RPLACA SLOTX () ))
(COND ((GREATERP (SETQ I (ADD1 I)) N)
(AND (NOT (ZEROP MODEFL)) CLBFL (CLEARACSMODE MODEFL)) (RETURN FL))
((NULL (SETQ SLOTX (CDR SLOTX)))
(SETQ N (DIFFERENCE #(NACS) N))
(GO A))
((GO B)))))
(DEFUN CLEARACS0 (CLBFL) (CLEARACS ##(+ (NACS) (NUMNACS)) CLBFL () ))
(DEFUN CLEARACS1 (X HOME)
(CLEARACS (COND ((AND X (GET X 'ACS))) (#(NACS))) 'T HOME)
(CLEARACS ##(- (NUMNACS)) 'T HOME))
(DEFUN CLEARVARS () (CLEARACS ##(+ (NACS) (NUMNACS)) () 'CLEARVARS))
(DEFUN CLEARNUMACS () (CLEARACS ##(- (NUMNACS)) 'T () ))
(DEFUN CLEARACSMODE (N)
(RPLACA ACSMODE () )
(COND ((> N #(NUMVALAC))
(RPLACA (CDR ACSMODE) () )
(COND ((> N ##(1+ (NUMVALAC)))
(RPLACA (CDDR ACSMODE) () ))))))
(DEFUN CLEANUPSPL (CLBFL)
;;; Clean up the SPLDLST by tossing out worthless stuff
;;; CLBFL=() allows carcdrings still in the slotlist to stay around
;;; for possible future VL crossings
(PROG (FL)
(SETQ FL 'T)
(MAP '(LAMBDA (LL)
(AND (NOT (COND ((ATOM (CDAR LL)) (CLMEMBER (CAAR LL) (CDAR LL) LDLST '=))
((ASSQ (CAAR LL) LDLST))
((NOT CLBFL) (ASQSLT (CAAR LL)))))
(RPLACA LL (SETQ FL () ))))
SPLDLST)
(AND (NULL FL) (FLUSH-SPL-NILS))))
(DEFUN CLCHK (PDL L) (AND PDL (CAR PDL) (NULL (CDAR PDL)) (ASSQ (CAAR PDL) L)))
(DEFUN CLLOC (Z MODE) (CONVNUMLOC (- (LENGTH Z) (LENGTH #(PDLGET MODE))) MODE))
(DEFUN CLMEMBER (X Y L FUN)
;;; A QUICK WAY OF DOING (MEMBER ZZ L) WHERE X = (CAR ZZ) Y = (CDR ZZ)
;;; AND THE EXPECTATION IS THAT THE "MEMBER" WILL USUALLY FAIL
(DO Z L (CDR Z) (NULL Z)
(AND (CAR Z)
(EQ X (CAAR Z))
(COND ((EQ FUN 'EQ) (EQ Y (CDAR Z)))
((EQ FUN '=) (AND (NUMBERP (CDAR Z)) (= (CDAR Z) Y)))
((EQ FUN 'EQUAL) (EQUAL Y (CDAR Z))))
(RETURN Z))))
(DEFUN CLOBBER-SLOT (X L)
(AND (SETQ X (ASSQ (CAR X) L))
(RPLACA (MEMQ X L) () ))
() )
;;; (FXP0) - Offset for FXPDL addresses, has 2↑11. bit off
;;; (FLP0) - Offset for FLPDL addresses, has 2↑12. bit off
(DEFUN CONVNUMLOC (AC MODE)
(COND ((NULL MODE) (COND ((> AC 0) (AC-ADDRS AC))
((> (SETQ AC (+ AC #(NPDL-ADDRS))) 0)
(PDL-ADDRS 0 AC))
('T (- AC #(NPDL-ADDRS)))))
(#(ACLOCP-N AC) (AC-ADDRS (+ AC ##(1- (NUMVALAC)))))
((PROG2 (SETQ AC (+ AC #(NPDL-ADDRS)))
(EQ MODE 'FIXNUM))
(COND ((> AC 0) (PDL-ADDRS 1 AC))
('T (+ AC ##(- (FXP0) (NPDL-ADDRS))))))
((EQ MODE 'FLONUM)
(COND ((> AC 0) (PDL-ADDRS 2 AC))
('T (+ AC ##(- (FLP0) (NPDL-ADDRS))))))))
(DEFUN CONT (N Y) (RPLACA (FIND N) Y))
(DEFUN CONTENTS (N) (CAR (FIND N)))
(DEFUN CPUSH (N) (FIND N) (CPUSH1 N () () ))
(DEFUN CPUSH-DDLPDLP (N AD)
(FIND N)
(AND (DVP1 SLOTX N) ;Have I diddled with the PDl for which
(EQ (CPUSH1 N () AD) 'PUSH) ; the address AD is an offset thereof?
#(PDLLOCP AD)
(EQ (GETMODE N) (GETMODE AD))))
;;; Must preserve SLOTX. If SLOTX = (FIND N) ,
;;; then CPUSH1 will compile a PUSH (or MOVE) to the PDL from N
;;; Returns either "PUSH", "T", or "()" depending on what happened.
(DEFUN CPUSH1 (N HOME DONT)
(COND ((OR (NULL (CAR SLOTX))
(EQ (CAAR SLOTX) 'QUOTE)
(EQ (CDAR SLOTX) 'DUP))
() )
((EQ (CDAR SLOTX) 'TAKEN) (AND (NOT (EQ HOME 'CLEARVARS)) (CPUSH2 (GETMODE N) N)))
(((LAMBDA (VFL)
(COND ((NOT (DVP2 (CAR SLOTX) N VFL)) () ) ;If not DVP, then return ()
((NOT VFL) ;For GENSYM stuff, PUSH only
(AND (NOT (EQ HOME 'CLEARVARS)) ;If not restricted by home
(CPUSH2 (GETMODE N) N)))
((EQ HOME 'GENSYM) () ) ;Vars not pushed if restricted
(((LAMBDA (MODE)
(COND ((CDAR SLOTX)
(OPUSH N (CAR SLOTX) MODE)
(RPLACA SLOTX () )
'PUSH)
((CPUSHFOO N DONT MODE) 'MOVEM) ;Take existing home-slot on PDL
((CPUSH2 MODE N))))
(GETMODE N))))) ; or create PDL home for local var
(VARBP (CAAR SLOTX))))))
(DEFUN CPUSH2 (MODE N)
(OPUSH N (CAR SLOTX) MODE)
(RPLACA SLOTX (CONS (CAAR SLOTX) 'DUP))
'PUSH)
(DEFUN CPUSHFOO (N DONT MODE)
((LAMBDA (T1 T2 SL BESTCNT BESTLOC M)
(AND (NOT (FIXP DONT)) (SETQ DONT () ))
(DO ((Z #(PDLGET MODE) (CDR Z))
(I 0 (1- I)))
((NULL Z))
(AND (EQ (CAAR SLOTX) (CAAR Z))
(PROG2 (SETQ T1 (CONVNUMLOC I MODE)) 'T)
(OR (NULL DONT) (NOT (= DONT T1)))
(COND ((AND (EQ (CDAR Z) 'OHOME)
(NOT (DVP4 (CAR Z) T1)))
(SETQ SL Z BESTLOC T1)
(RETURN () ))
((NOT (DVP1 Z T1))))
(PROG2 (SETQ T2 (COND ((NUMBERP (CDAR Z)) (CDAR Z)) (CNT)))
(> T2 BESTCNT))
(SETQ SL Z BESTLOC T1 BESTCNT T2)))
(COND (SL (SETQ M (LENGTH #(PDLGET MODE)))
(AND (REGADP N)
(NOT (REGADP BESTLOC))
(SETQ SLOTX
(PROG2 () SLOTX
(SETQ N (LOADINSOMENUMAC
(CONS (CAR (CONTENTS N)) CNT))))))
(SETQ BESTLOC (+ BESTLOC
(COND ((MINUSP (SETQ M (- M (LENGTH #(PDLGET MODE))))) 1)
((PLUSP M) -1)
(0))))
(COND ((AND (= N 1)
(= BESTLOC 0)
(NULL MODE)
(AND (NOT ATPL) (NOT ATPL1))
(MEMQ (CAR LOUT) '(CALL CALLF))
(EQUAL LOUT1 '(PUSH P 1)))
(SETQ LOUT1 (SETQ ATPL1 'FOO))
(OUTPUT '(PUSH P 1)))
('T (OUT1 'MOVEM N BESTLOC)))
(RPLACA SL (PROG2 ()
(CAR SLOTX)
(RPLACA SLOTX (CONS (CAAR SLOTX) 'DUP))))
'T)))
0 0 () 0 0 0))
;;; Apparently the value of CSLD is umimportant
(DEFUN CSLD (VFL CCFL SETQLIST)
(PROG (L TEM T2 NLARG V)
(SETQ T2 0 NLARG 0)
(DO Z LDLST (CDR Z) (OR (NULL Z) (EQ Z EXLDL))
(SETQ V (CAAR Z))
(COND ((NULL (CDAR Z)) ; ITEM IS LIKE (G00001)
(AND CCFL
(SETQ TEM (ASSQ V SPLDLST))
(NOT (ASQSLT V))
(PUSH TEM L)))
;;; ### Does a "MEMQ" really work here? Is "MEMBER" or "CLMEMBER" necessary?
((AND (OR (AND VFL (MEMQ (CAR Z) SPLDLST)) ;Loading up SPECIAL vars
(AND SETQLIST (MEMQ V SETQLIST))) ;Loading SETQ vars
(COND ((NOT (NUMBERP (SETQ TEM (ILOC2 'T (CAR Z) (VARMODE V))))))
((PROG2 (SETQ NLARG TEM) #(PDLLOCP-N NLARG))
(NULL (CDR (CONTENTS TEM))))
((AND #(ACLOCP-N NLARG)
(MEMQ (CDR (CONTENTS TEM)) '(DUP () )))
(AND (NOT (SPECIALP V)) (CPUSH TEM))
#(LET ((REGACS REGACS) (NUMACS NUMACS))
(SETQ REGACS (APPEND REGACS () )
NUMACS (APPEND NUMACS () ))
(MAP '(LAMBDA (SL)
(AND (CAR SL)
(EQ (CAAR SL) V)
(RPLACA SL () )))
(APPEND NUMACS REGACS))
(SETQ TEM (ILOC2 'T (CAR Z) (VARMODE V))))
(OR (NOT (NUMBERP TEM)) (NULL (CDR (CONTENTS TEM)))))
(T)))
(PUSH (CAR Z) L))))
;;; At this point, L is the list of goodies to be loaded
(MAPC
'(LAMBDA (X)
(COND ((NOT (ATOM (CDR X))) ;Like (G0001 CAR X . 3)
(COND ((NOT (EQ (PROG2 () VL (SETQ T2 (CARCDR X 1))) VL)) ;Did this carcdr add
(OPUSH T2 (LIST (CAR X)) () )) ; to the VL hackery?
((CPUSH2 () T2))))
((AND (SETQ T2 (NUMBERP (SETQ TEM (ILOC0 X () ))))
(PROG2 (SETQ NLARG TEM) #(PDLLOCP-N NLARG))
(NOT (DVP TEM)))
(CONT TEM (CONS (CAR X) 'IDUP))) ;LIKE (X.N)
((OPUSH TEM
(COND ((AND T2 (NUMBERP (CDR (SETQ T2 (CONTENTS TEM))))) T2)
((CONS (CAR X) 'IDUP)))
() ))))
L)))
(DEFUN CPVRL ()
(COND (LPRSL)
('T (SETQ LPRSL '(0 0 0))
(CNPUSH PVRL 'T)
(SETQ PRSSL (SLOTLISTCOPY))
(SETQ LPRSL (LIST (LENGTH REGPDL) (LENGTH FXPDL) (LENGTH FLPDL))))))
(DEFUN CNPUSH (L FL)
(AND L
(PROG (NN XN LN MODE LOC ITEM Z ZZ)
(DECLARE (FIXNUM NN XN LN))
(SETQ NN 0 XN 0 LN 0)
A (SETQ MODE (VARMODE (CAR L)))
(SETQ LOC (ILOC1 'T (SETQ ITEM (CONS (CAR L) CNT)) MODE))
(COND ((OR LOC (AND MODE (ASSQ (CAR L) REGACS) (SETQ LOC (ILOC1 'T ITEM () ))))
(AND FL #(ACLOCP LOC) (PUSH LOC ZZ)))
('T (RPLACD ITEM () )
(COND ((NULL MODE) (PUSH ITEM REGPDL) (SETQ NN (1+ NN)))
((EQ MODE 'FIXNUM) (PUSH ITEM FXPDL) (SETQ XN (1+ XN)))
('T (PUSH ITEM FLPDL) (SETQ LN (1+ LN))))))
(AND (SETQ L (CDR L)) (GO A))
(AND (NOT (ZEROP NN)) (CNPUSH1 NN 0)) ;0 IS FOR P
(AND (NOT (ZEROP XN)) (CNPUSH1 XN 1)) ;1 IS FOR FXP
(AND (NOT (ZEROP LN)) (CNPUSH1 LN 2)) ;2 IS FOR FLP
(MAPC 'CPUSH ZZ)
(RETURN Z))))
(DEFUN CNPUSH1 (N PDL)
(DECLARE (FIXNUM N PDL MAX)) ;PDL IS THE NUMBER DESIGNATING
(PROG (MAX) ; WHICH PDL. N IS THE AMOUNT
(SETQ MAX (PVIA PDL 0)) ; TO BE PUSHED, AND MAX IS THE
A (COND ((> N MAX) ; MAX BITE IN ONE CHUNK
(OUTPUT (PVIA PDL MAX))
(SETQ N (- N MAX))
(GO A))
((> N 2) (OUTPUT (PVIA PDL N)))
((> N 0)
(OUTPUT (PVIA PDL 1))
(AND (= N 2) (OUTPUT (PVIA PDL 1)))))))
(DEFUN DIDUP (L)
(COND (L (COND ((EQ L CLPROGN))
((MEMQ PROGN L) (SETQ L CLPROGN)))
(DIDU1 REGACS L)
(DIDU1 NUMACS L)
(DIDU1 REGPDL L)
(DIDU1 FXPDL L)
(DIDU1 FLPDL L))))
(DEFUN DIDU1 (SLOT L)
(AND SLOT
(DO ZZ (ASSOCR 'IDUP SLOT) (ASSOCR 'IDUP (CDR ZZ)) (NULL ZZ)
(AND (OR (EQ L CLPROGN) (MEMQ (CAAR ZZ) L))
(RPLACA ZZ (CONS (CAAR ZZ) CNT))))))
(DEFUN DVP (I) (DVP1 (FIND I) I))
(DEFUN DVP1 (SL I)
;;; Tells whether item must be saved (at this point). Should not change SLOTX, eg by calling FIND
(COND ((OR (NULL (CAR SL))
(EQ (CAAR SL) 'QUOTE)
(EQ (CDAR SL) 'DUP))
() )
((MEMQ (CDAR SL) '(TAKEN IDUP)))
((DVP2 (CAR SL) I (VARBP (CAAR SL))))))
(DEFUN DVP2 (ITEM I VFL) ;VFL must be result of VARBP
(COND (VFL (COND ((AND (EQ VFL 'SPECIAL)
(MEMQ (CDR ITEM) '(DUP () ))) ;Current home of spec var
() )
((AND (NOT (EQ VFL 'SPECIAL)) ;Current home of local var
(OR (NULL (CDR ITEM)) (EQ (CDR ITEM) 'OHOME))) ; whose time has not yet
(SETQ VFL (ASSQ (CAR ITEM) LOCVARS))
(OR (< CNT (CDR VFL)) (DVP4 ITEM I))) ; run out [or is still DVP4]
((NOT (NUMBERP (CDR ITEM)))
(BARF (LIST I ITEM) |Whass happnin - DVP2|))
(#(ACLOCP I)
(SETQ VFL (GETMODE I)) ;Var in AC is not DVP if an
(SETQ VFL #(PDLGET VFL)) ;IDUP or same-count copy is
(COND ((OR (CLMEMBER (CAR ITEM) 'IDUP VFL 'EQ) ; on PDL
(CLMEMBER (CAR ITEM) (CDR ITEM) VFL '=))
() )
((DVP4 ITEM I))))
((DVP4 ITEM I))))
((ASSQ (CAR ITEM) LDLST)) ;Internal computation quantity on LDLST
(VL (DVP3 (CAR ITEM) VL)))) ;VarList crossings
(DEFUN DVP3 (VAR L)
(AND L
(SETQ L (DO ZZ L (CDR ZZ) (NULL ZZ) ;Look for crossing for this var
(AND (EQ VAR (CAAR ZZ)) (RETURN ZZ))))
((LAMBDA (XTN LL)
(COND ((AND LL (NOT (ASQSLT XTN)))) ;A primary, needed crossing
((NULL (CDR L)) () ) ;No more potential crossings
((AND (NULL LL) (DVP3 XTN (CDR L)))) ;Look for "grandsons"
((DVP3 VAR (CDR L))))) ;Look for more direct "sons"
(CDAR L) (ASSQ (CDAR L) LDLST))))
(DEFUN DVP4 (ITEM I)
(AND (ASSQ (CAR ITEM) LDLST) ;Basic var DVP utilizing LDLST
((LAMBDA (MODE VAR)
(DO ((Z LDLST (CDR Z)) ;If any item on LDLST needs data
(PDLP (AND #(PDLLOCP-N I) (NUMBERP (CDR ITEM))))
(FL (AND MODE (ASSQ VAR REGACS)))
(TEM))
((NULL Z))
(AND (EQ (CAAR Z) VAR)
(NUMBERP (SETQ TEM (COND (FL #(ILOCNUM (CAR Z) () ))
((ILOC1 'T (CAR Z) MODE)))))
(OR (= I TEM) ;If (X.4) in both PDL and AC and
(AND PDLP ;Somebody on LDLST wants either
(> TEM 0) ;Slot, then PDL slot is DVP
(EQUAL ITEM (GCONTENTS TEM))))
(RETURN 'T))))
(VARMODE (CAR ITEM)) (CAR ITEM))))
(DEFUN EASYGO () ;Should be nothing on LDLST except what was there
(AND (EQ PROGP LDLST) ; upon entry to the PROG
(NULL GOBRKL) ;Not be in LAMBDA requiring special unbind
(= (LENGTH REGPDL) (CAR LPRSL)) ; and not under CATCH or ERRSET
(= (LENGTH FXPDL) (CADR LPRSL)) ;SLOTLIST not need restore to PROG level
(= (LENGTH FLPDL) (CADDR LPRSL))))
(DEFUN FIND (N)
(SETQ SLOTX (COND ((PLUSP N)
(COND (#(NUMACP-N N) (SETQ N (- N #(NUMVALAC))) NUMACS)
('T (SETQ N (1- N)) REGACS)))
((NOT #(NUMPDLP-N N)) (SETQ N (- N)) REGPDL)
(#(FLPDLP-N N) (SETQ N (- #(FLP0) N)) FLPDL)
('T (SETQ N (- #(FXP0) N)) FXPDL)))
(COND ((ZEROP N) SLOTX)
((SETQ SLOTX #(NCDR SLOTX N)))))
(DEFUN FLUSH-SPL-NILS ()
(AND SPLDLST
(PROG (L OL)
A (AND (NULL (CAR SPLDLST)) (SETQ SPLDLST (CDR SPLDLST)) (GO A))
(SETQ OL (SETQ L SPLDLST))
B (AND (NULL (SETQ L (CDR L))) (RETURN SPLDLST))
(COND ((NULL (CAR L)) (RPLACD OL (CDR L)))
((SETQ OL L)))
(GO B))))
(DEFUN FRACF ()
((LAMBDA (N)
(COND ((ZEROP N) (SETQ SLOTX REGACS) (CPUSH1 1 () () ) 1)
(N)))
(FRAC)))
(DEFUN FRAC ()
(COND ((NULL (CAR (SETQ SLOTX REGACS))) 1) ;This bletcherous code is
((NULL (CAR (SETQ SLOTX (CDR SLOTX)))) 2) ;here purely for speed
((NULL (CAR (SETQ SLOTX (CDR SLOTX)))) 3) ;reasons, since calls to
((NULL (CAR (SETQ SLOTX (CDR SLOTX)))) 4) ;these functions are so frequent
((NULL (CAR (SETQ SLOTX (CDR SLOTX)))) 5)
((DO N (PROG2 (SETQ SLOTX REGACS) 1)
(PROG2 (SETQ SLOTX (CDR SLOTX)) (1+ N))
(> N #(NACS))
(AND (NOT (DVP1 SLOTX N)) (RETURN N))))
(0)))
(DEFUN FRACB ()
((LAMBDA (Y)
(COND ((NULL (CADR Y)) (SETQ SLOTX (CDDR SLOTX)) 5) ;TRIES EMPTY 5,4,3 FIRST IN THAT ORDER,
((NULL (CAR Y)) (SETQ SLOTX (CDR SLOTX)) 4) ;THEN TRIES NON-DVP AC IN BACKWARDS ORDER
((NULL (CAR SLOTX)) 3) ;ASSUMING SLOT IS BEING USED FOR TEMPS
((NOT (DVP1 (CDR Y) 5)) (SETQ SLOTX (CDR Y)) 5)
((NOT (DVP1 Y 4)) (SETQ SLOTX Y) 4)
((NOT (DVP1 SLOTX 3)) 3)
((NOT (DVP1 (SETQ SLOTX (CDR REGACS)) 2)) 2)
((1FREE) (SETQ SLOTX REGACS) 1)
(0)))
(CDR (SETQ SLOTX (CDDR REGACS))))) ;THIS HAD BETTER YIELD SLOTX = (FIND 3)
(DECLARE (AND (< #(NACS) 5) (BARF () |FRACB is losing|)))
(DEFUN FRAC1 ()
((LAMBDA (AC)
(COND ((1FREE) (SETQ SLOTX REGACS) 1)
((NOT (ZEROP (SETQ AC (FRACB)))) AC)
('T (SETQ SLOTX REGACS) (CPUSH1 1 () () ) 1)))
0))
(DEFUN FRAC5 ()
((LAMBDA (N) (COND ((NOT (ZEROP N)) N)
('T (SETQ SLOTX (CDDDDR REGACS)) ;Must be set SLOTX = (FIND 5)
(CPUSH1 #(NACS) () () )
#(NACS))))
(FRACB)))
(DEFUN FREEREGAC (F)
((LAMBDA (AC) (COND ((ZEROP AC) (BARF () |No free acs - FREEREGAC|) 0)
(AC)))
(COND ((EQ F 'FRAC) (FRAC)) ((FRACB)))))
(DEFUN FREEIFYNUMAC ()
(OR (NOT (ZEROP (FREENUMAC1))) ;Insure that there is at least
(PROG2 (CLEARACS ##(- (NUMNACS)) () 'T) ; one free NUMAC
(NOT (ZEROP (FREENUMAC1))))
(FREENUMAC0)))
(DEFUN FREENUMAC ()
((LAMBDA (AC)
(AND (ZEROP AC) (SETQ AC (FREENUMAC0)))
AC)
(FREENUMAC1)))
(DEFUN FREENUMAC1 ()
(COND ((AND (NULL (CAR (SETQ SLOTX NUMACS))) (NOT (= TAKENAC1 ##(NUMVALAC))))
##(NUMVALAC))
((AND (NULL (SETQ SLOTX (CDR SLOTX)))
(NOT (= TAKENAC1 ##(+ (NUMVALAC) 1))))
##(+ (NUMVALAC) 1))
((AND (NULL (SETQ SLOTX (CDR SLOTX)))
(NOT (= TAKENAC1 ##(+ (NUMVALAC) 2))))
##(+ (NUMVALAC) 2))
((DO I (PROG2 (SETQ SLOTX NUMACS) #(NUMVALAC))
(PROG2 (SETQ SLOTX (CDR SLOTX)) (1+ I))
(NULL SLOTX)
(AND (NOT (= I TAKENAC1)) (NOT (DVP1 SLOTX I)) (RETURN I))))
(0)))
(DEFUN FREENUMAC0 ()
(SETQ SLOTX NUMACS)
(COND ((= TAKENAC1 #(NUMVALAC))
(SETQ SLOTX (CDR SLOTX))
(CPUSH1 (1+ #(NUMVALAC)) () () )
(1+ #(NUMVALAC)))
('T (CPUSH1 #(NUMVALAC) () () )
#(NUMVALAC))))
(DEFUN FUNMODE (F)
(DO Y MODELIST (CDR Y) (NULL Y)
(AND (NOT (ATOM (CAAR Y)))
(EQ (CAAAR Y) F)
(RETURN (CDAR Y)))))
(DEFUN FUNTYP-DECODE (X)
((LAMBDA (T1)
(COND (T1 (COND ((EQ (CAR T1) 'FUNTYP-INFO) (CAADR T1))
((CAR T1))))
((SETQ T1 (GETL X '(SUBR LSUBR FSUBR)))
(AND (SYSP (CADR T1)) (CAR T1)))))
(GETL X '(JSP CARCDR *EXPR *FEXPR *LEXPR FUNTYP-INFO))))
(DEFUN GCDR (F L)
; Generalized CDR
(PROG ()
(AND (NULL L) (RETURN () ))
##(COND ((NOT (MEMQ COMPILER-STATE '(() TOPLEVEL)))
'(SETQ F (GET F 'SUBR)))
('B))
A (COND ((AND L (NOT ##(COND ((NOT (MEMQ COMPILER-STATE '(() TOPLEVEL)))
'(SUBRCALL T F L))
('(FUNCALL F L)))))
(POP L)
(GO A)))
(RETURN L)))
;;; Get contents, but dont change SLOTX
(DEFUN GCONTENTS (X)
((LAMBDA (SVSLT) (PROG2 () (CONTENTS X) (SETQ SLOTX SVSLT))) SLOTX))
(DEFUN GENTAG (TAG)
(OR (SYMEVAL TAG)
(PROGN (SET TAG (SETQ TAG (GENSYM)))
(PUSH (CONS () TAG) GL)
(PUTPROP TAG 'T 'USED)
TAG)))
(DEFUN GETMODE (N)
(COND ((PLUSP N) (GETMODE0 N #(NUMACP-N N) 'T))
((NOT #(NUMPDLP-N N)) () )
(#(FLPDLP-N N) 'FLONUM)
('FIXNUM)))
(DEFUN GETMODE0 (N ACP SHEE-IT)
(COND ((AND ACP (CAR #(ACSMODESLOT N))))
(((LAMBDA (TEMP)
(COND ((NULL (SETQ TEMP (GCONTENTS N)))
(BARF N |No thing - GETMODE|))
((EQ (CAR TEMP) 'QUOTE)
(CAR (MEMQ (TYPEP (CADR TEMP)) '(FIXNUM FLONUM))))
((NUMERVARP (CAR TEMP)))
((AND ACP (NOT (VARBP (CAR TEMP))))
(COND (FIXSW 'FIXNUM)
(FLOSW 'FLONUM)
(SHEE-IT (BARF N |No mode - GETMODE|) () )))))
() ))))
;;; INTERNAL LOCATORS - RETURN ONE OF
;;; () ;Not found
;;; ((QUOTE MUMBLE) . ()) ;Quoted thing
;;; (SPECIAL FOO) ;Current value of special var
;;; 1 => 5 ;Quantity in REGACS
;;; 7 => 11[8] ;" " NUMACS
;;; -3777[8] => 0 ;" " REGPDL
;;; -7777[8] => -4000[8] ;" " FXPDL
;;; -INF => -10000[8] ;" " FLPDL
(DEFUN ILOC0 (X MODE)
;;; Should not change SLOTX, e.g. by calling FIND, or CONT, or CONTENTS
;;; Internally-located? - SPECIAL value cells, QUOTE stuff, and SLOTLIST
;;; entries are internal places acceptable. REturns best of these if x is
;;; somewhere therein; otherwise ().
(COND ((EQ (CAR X) 'QUOTE) (LIST X))
((ILOC1 (VARBP (CAR X)) X MODE))))
(DEFUN ILOC1 (FL X MODE)
(DO ((I 1 (ADD1 I)) (Y #(ACSGET MODE) (CDR Y))
(ENDFLAG) (T1) (BESTLOC 0) (BESTCNT 0))
((COND ((NULL Y)
(COND (ENDFLAG)
('T (SETQ ENDFLAG 'T)
(NULL (SETQ Y #(PDLGET MODE)))))))
(COND ((NOT (ZEROP BESTCNT))
(CONVNUMLOC (COND ((< BESTLOC (SETQ T1 #(NACSGET MODE))) BESTLOC)
((- T1 BESTLOC)))
MODE))
(MODE () )
((AND FL (SPECIALP (CAR X))))
((AND (NOT FL) (SETQ FL (ASSOCR (CAR X) VL)))
(ILOC1 () (CONS (CAAR FL) (CDR X)) () ))))
(AND (CAR Y)
(EQ (CAAR Y) (CAR X))
(COND ((MEMQ (CDAR Y) '(() DUP IDUP))
(COND ((ZEROP BESTCNT)
(SETQ BESTLOC I BESTCNT 35397.) ;total random no.
(COND ((NOT FL) (SETQ Y () ENDFLAG 'T))))))
; THE FIRST INSTANCE IN THE SLOTLIST OF A GENSYM QUANTITY WILL BE THE RIGHT ONE
((AND FL (CDR X)
(NUMBERP (SETQ T1 (COND ((EQ (CDAR Y) 'OHOME) (GET (CAAR Y) 'OHOME))
((CDAR Y)))))
(NOT (< T1 (CDR X)))
(OR (ZEROP BESTCNT) (> BESTCNT T1)))
(SETQ BESTCNT T1 BESTLOC I))))))
(DEFUN ILOC2 (FL V TYPE)
(COND ((AND (NULL FL) (EQ (CAR V) 'QUOTE)) (LIST V))
((ILOC1 FL V TYPE))
((AND TYPE (ILOC1 FL V () )))
((AND (NULL FL) (ASSQ (CAR V) SPLDLST)) () )
('T (BARF V |Lost ? - ILOC2|) () )))
(DEFUN ILOCMODE (ITEM ACORFUN TYPE)
(COND ((EQ (CAR ITEM) 'QUOTE) (LIST ITEM))
((PROG (Z NPZ ZZ ATP FL NUMWORLD)
(SETQ ATP (ATOM TYPE) NUMWORLD (AND ATP TYPE))
(SETQ FL (VARBP (CAR ITEM)))
(SETQ Z (ILOC1 FL ITEM NUMWORLD))
(COND ((NULL Z)
(RETURN (COND ((COND (NUMWORLD (SETQ ZZ (ILOC1 FL ITEM () )))
((AND ATP ACORFUN) () )
((SETQ ZZ (COND (FL (SETQ NPZ (VARMODE (CAR ITEM)))
(COND ((NULL NPZ) () )
((ILOC1 T ITEM NPZ))
((ILOC1 T
ITEM
(COND ((EQ NPZ 'FIXNUM)
'FLONUM)
('FIXNUM))))))
((ILOC1 T ITEM 'FIXNUM))
((ILOC1 T ITEM 'FLONUM))))))
ZZ)
((NULL ACORFUN) () )
((SETQ ZZ (ASSQ (CAR ITEM) SPLDLST)) (CARCDR ZZ ACORFUN))
((BARF ITEM |Lost datum - ILOCMODE|)))))
((COND ((OR (NULL TYPE) (NULL FL))) ;Tedious decision as to whether or not to
((NUMERVARP (CAR ITEM)) () ) ; try the other areas
((NOT (ASSQ (CAR ITEM) NUMACS))) ;Numvars locatable in regarea must be sought in
(NUMWORLD () ) ; the numworld, and ILOCNUMs might want to check
((NULL (CAR TYPE)))) ; the NUMACS
(RETURN Z))
((PROG2 (SETQ NPZ (NUMBERP Z))
NUMWORLD) ;Type = FIXNUM [or FLONUM]
(AND (OR (NOT NPZ)
(NOT (NUMBERP (SETQ ZZ (ILOC1 FL ITEM () )))))
(RETURN Z))
(SETQ ZZ (PROG2 () Z (SETQ Z ZZ))))
('T (AND (COND ((NULL (CAR TYPE)) (NOT NPZ)) ;(() FIXNUM FLONUM) => call by ILOCREG
((NOT NPZ) (NOT (EQ (CAR Z) 'SPECIAL))))
(RETURN Z)) ;(FIXNUM FLONUM) => call by ILOCNUM
(SETQ ZZ (COND ((ILOC1 FL ITEM 'FIXNUM))
((ILOC1 FL ITEM 'FLONUM))
('T (RETURN Z))))
(AND (NOT NPZ) (RETURN ZZ))))
;So a call for ILOCREG or ILOCNUM has resulted in finding copies in both
; the numworld and the regworld. So we have to ascertain which copy is best
;Z holds result of (ILOC0 ITEM () ), i.e. the regworld loc, and
;ZZ that for (ILOC0 ITEM 'FIXNUM) [or 'FLONUM], the numworld loc
;RCNT is the time-count for the regworld slot, NCNT for the number world
(RETURN ((LAMBDA (RCNT NCNT)
(AND (NOT (NUMBERP RCNT)) (SETQ RCNT () ))
(AND (NOT (NUMBERP NCNT)) (SETQ NCNT () ))
(COND ((AND (NOT NCNT) (NOT RCNT))
(COND ((NUMBERP ACORFUN) (COND (#(NUMACP ACORFUN) ZZ) (Z)))
((AND FL (NUMERVARP (CAR ITEM))) ZZ)
((NULL (CAR TYPE)) Z)
(ZZ)))
((AND NCNT RCNT) (COND ((< RCNT NCNT) Z) (ZZ))) ;PREFER LOWER OF TWO COUNTS
((AND RCNT (< RCNT CNT)) Z) ;PREFER A COUNT TO A HOME
(ZZ))) ;IF COUNT IS ACCEPTABLE
(CDR (GCONTENTS Z))
(CDR (GCONTENTS ZZ))))))))
(DEFUN ITEML (Y PROP)
; ITEML compiles an itemlist and returns a list of the compiled
; arguments (internal names therefor, that is) in reverse order
(DO ((AC 1 (ADD1 AC)) (Y Y (CDR Y)) (PNOB 'T 'T)
(Z) (ITEM) (LOC) (ARGNO 1) (EFFS)
(PROP (AND PROP (CDDR PROP)) (AND PROP (CDR PROP))))
((NULL Y) Z)
(SETQ ARGNO (COND ((NULL PROP) AC)
;Oddly enuf, the next case is for CONS etc.
((EQ (CAR PROP) 'PNOB) (SETQ PNOB () ) 1)
((MEMQ (CAR PROP) '(FIXNUM FLONUM)) #(NUMVALAC))
('T AC)))
(PUSH (SETQ ITEM (COMP0 (CAR Y))) Z)
(AND (= ARGNO #(NUMVALAC))
(SETQ LOC (ILOC0 ITEM (CAR PROP)))
#(NUMACP LOC)
(SETMODE LOC (CAR PROP)))))
(DEFUN L/.LE/. (L LL) ;Length L less-than-or-equal-to Length LL
(PROG ()
A (AND (NULL L) (RETURN (COND (LL 'LESSP) ('EQUAL))))
(AND (NULL LL) (RETURN () ))
(SETQ L (CDR L) LL (CDR LL))
(GO A)))
(DEFUN L2F (X)
(COND ((OR (NULL X) (NULL (CDR X))) X)
('T (SETQ X (REVERSE X)) (RPLACD X (NREVERSE (CDR X))))))
(DEFUN LSUB (L LL)
(COND ((NULL LL) L)
((NOT (MEMQ (CAR LL) L)) (LSUB L (CDR LL)))
((MAPCAN '(LAMBDA (X) (COND ((MEMQ X LL) () )
((LIST X))))
L))))
(DEFUN LADD (L LL)
(COND ((NULL L) LL)
((LADD (CDR L) (ADD (CAR L) LL)))))
(DEFUN LAND (L LL)
(COND ((OR (NULL L) (NULL LL)) () )
((NOT (MEMQ (CAR LL) L)) (LAND L (CDR LL)))
((MAPCAN '(LAMBDA (X) (AND (MEMQ X L) (LIST X))) LL))))
(DEFUN LJOIN (L LL) ;Like APPEND, but tries
(COND ((NULL L) LL) ; interchanging args if
((NULL LL) L) ; that will reduce consing
('T (AND (< (LENGTH LL) (LENGTH L))
(SETQ L (PROG2 () LL (SETQ LL L))))
(APPEND L LL))))
(DEFUN LEVELTAG ()
((LAMBDA (Y)
(PUTPROP Y (SLOTLISTCOPY) 'LEVEL) Y)
(GENSYM)))
(DEFUN LEVEL (TAG)
(COND ((GET TAG 'LEVEL))
((ASSOCR TAG GL) PRSSL)
((BARF TAG |Tag with no slotlist level|))))
(DEFUN LOADACS (X HLAC PROP)
(COND ((OR (NULL PROP) (NULL (SETQ PROP (CAR PROP))))
(SETQ PROP '(() () () () () )))
((< (LENGTH PROP) HLAC)
(DO I (- HLAC (LENGTH PROP)) (1- I) (SIGNP LE I)
(PUSH () PROP))))
(DO ((AC HLAC (1- AC)) (FLAG () () ) (TEM))
((ZEROP AC))
(COND ((OR (NULL PROP)
(NULL (CAR PROP))
(SETQ FLAG (AND (EQ (CAR PROP) 'PNOB) 'PNOB))
(PROG2 (SETQ TEM #(ILOCREG (CAR X) AC)) (REGADP TEM)))
(LOADAC (CAR X) AC FLAG))
((MAKEPDLNUM (CAR X) AC)))
(POP PROP)
(POP X)))
(DEFUN LOADAC (VAR AC CONSFL)
;CONSFL = T means no pdlnumbers allowed.
;CONSFL = PNOB means no new pdlnumbers allowed, but existing ones ok
;CONSFL = () means anything goes
#(LET ((LOC #(ILOCREG VAR AC)))
(COND ((COND ((NULL CONSFL) () )
((EQ (CAR VAR) 'QUOTE) () )
(#(NUMACP-N AC) () )
((NOT (REGADP LOC))
(OR (NOT (EQ CONSFL 'PNOB)) #(ACLOCP LOC)))
((EQ CONSFL 'PNOB) () )
((UNSAFEP VAR)))
(SETQ VAR (MAKESAFE VAR LOC 'REMOVEB))
(SETQ LOC (ILOC0 VAR () )))
('T (REMOVEB VAR)))
(COND (#(NUMACP-N AC) (LOADINNUMAC VAR AC LOC 'REMOVEB))
((NOT (NUMBERP LOC)) ;((QUOTE <frob>)) or (SPECIAL <var>)
(CPUSH AC) ;Sets SLOTX to (FIND AC)
(COND ((AND (NOT (EQ (CAR LOC) 'SPECIAL)) ;If QUOTE stuff to be loaded
(CAR SLOTX) ; is already there then do nothing
(EQ (CAAR SLOTX) 'QUOTE)
(EQUAL VAR (CAR SLOTX))))
((AND (NOT (EQ (CAR LOC) 'SPECIAL))
(MEMQ (CADAR LOC) '(T () )))
(COND ((CADAR LOC) (OUTPUT (BOLA AC 2))) ;(MOVEI AC 'T)
((AND (NOT ATPL) ;Convert (MOVEI AD '() )
(EQ (CAR LOUT) 'MOVEI) ; (MOVEI AC '() )
(NOT (ATOM (CADDR LOUT))) ;Into (SETZB AD AC)
(QNILP (CADDR LOUT)))
((LAMBDA (AD)
(SETQ LOUT (SETQ ATPL 'FOO))
#(OUTFS 'SETZB AD AC))
(CADR LOUT)))
('T (OUTPUT (BOLA AC 5))))) ;(MOVEI AC '() )
('T (OUT1 'MOVE AC LOC)))
(CONT AC (COND ((EQ (CAR LOC) 'SPECIAL) (LIST (CAR VAR)))
(VAR))))
(#(LET ((LOC-IN-ACP #(ACLOCP LOC)) (NLARG 0))
(COND ((AND LOC-IN-ACP
(PROG2 (SETQ NLARG LOC) (NOT #(NUMACP-N NLARG)))
(EQ (CDAR (FIND LOC)) 'DUP) ;SLOTX is where LOC is in AC
REGPDL
(EQ (CAAR SLOTX) (CAAR REGPDL)) ; of PDL and DUP in AC
(NOT (VARBP (CAAR SLOTX))) ;GENSYM quantity on top
(NOT (DVP1 SLOTX 0))) ; was found
(RPLACA SLOTX () ) ;Change LOC to top of PDL
(SETQ LOC 0)))
(COND ((AND LOC-IN-ACP (= LOC AC)) (CPUSH AC))
((NOT (REGADP LOC)) (PUSH VAR LDLST) (MAKEPDLNUM VAR AC))
('T ((LAMBDA (ACLOC DAC DATAORG DOD)
(COND ((AND (ZEROP LOC) (NOT DOD) (NOT DAC))
(OPOP AC () )
(RPLACA ACLOC DATAORG))
((AND (NOT DOD)
(CAR ACLOC)
(COND (#(PDLLOCP LOC)
(OR (= LOC 0)
(NOT (AND DAC (VARBP (CAAR ACLOC))))))
((PLUSP HLAC) ;SAYS CALL FROM LOADACS
(OR (> LOC HLAC) (< LOC AC)))))
(OUT1 'EXCH AC LOC)
(CONT LOC (CAR ACLOC))
(RPLACA ACLOC DATAORG))
('T (AND DAC
(PROG2 (FIND AC)
(EQ (CPUSH1 AC () LOC) 'PUSH))
#(PDLLOCP LOC)
(SETQ LOC (ILOC0 VAR () )))
(COND ((AND LOC-IN-ACP
(NOT ATPL)
(EQ (CAR LOUT) 'POP)
(= LOC (CADDR LOUT))
(EQ (CADR LOUT) 'P))
(SETQ LOUT (SETQ ATPL 'FOO))
(CONT LOC () )
(COND (DOD #(OUTFS 'MOVE AC 0 'P)
(PUSH DATAORG REGPDL))
(#(OUTFS 'POP 'P AC))))
('T (COND ((AND LOC-IN-ACP
(> LOC AC)
(PLUSP HLAC)
(NOT (> LOC HLAC))
(NOT ATPL)
(EQ (CAR LOUT) 'EXCH)
(EQUAL AC (CADDR LOUT))
(EQUAL LOC (CADR LOUT)))
(SETQ LOUT (SETQ ATPL 'FOO))
(OUT1 'MOVE LOC AC))
('T (OUT1 'MOVE AC LOC)))))
(RPLACA ACLOC
(COND ((NUMBERP (CDR DATAORG)) DATAORG)
((CONS (CAR DATAORG) 'DUP)))))))
(FIND AC) ;FIND AND CONTENTS SET SLOTX
(DVP1 SLOTX AC)
(CAR (FIND LOC))
(DVP1 SLOTX LOC))))))) ))
(DEFUN LOADINREGAC (X FUN LOC)
; Place a quantity X in some regular accumulator, removeing from LDLST
; "FUN" is advice or heuristic as to which acc is preferable,
; and can be "FRACB", "()", "FREACB", or some specific accumulator number.
; LOC is current location of X; () => look it up again
(AND (NULL LOC) (SETQ LOC #(ILOCF X)))
(COND (#(REGACP LOC) (REMOVEB X) (CPUSH LOC))
((NOT (ZEROP (SETQ LOC (COND ((EQ FUN 'FRACB) (FRACB))
((OR (NULL FUN) (EQ FUN 'FREACB)) #(FREACB))
(#(REGACP FUN) FUN)
('T 0)))))
(LOADAC X LOC () ))
('T (SETQ LOC 0)))
LOC)
(DEFUN LOADINSOMENUMAC (ITEM) (LOADINNUMAC ITEM 0 () 'REMOVEB))
(DEFUN LOADINNUMAC (ITEM AC LOC RMFLG)
(PROG (ACFLG MODE NLARG)
(SETQ ACFLG 'T)
(AND (NULL LOC)
(SETQ LOC #(ILOCNUM ITEM (COND ((ZEROP AC) (SETQ ACFLG () ) 'FREENUMAC)
('T AC)))))
(COND ((EQ RMFLG 'REMOVEB) (REMOVEB ITEM) (SETQ RMFLG () ))
((EQ RMFLG 'REMOVE) (SETQ RMFLG ITEM)))
(COND ((REGADP LOC)
(AND (NOT ACFLG) (SETQ AC (FREENUMAC)))
(AND (NUMBERP LOC) (SETQ ITEM (CONTENTS LOC)))
(SETQ ACFLG (CAR ITEM))
(COND ((EQ ACFLG 'SPECIAL) (SETQ ACFLG (CADR ITEM))))
(SETQ MODE (COND ((AND (EQ ACFLG 'QUOTE)
(MEMQ (SETQ MODE (TYPEP (CADR ITEM)))
'(FIXNUM FLONUM)))
MODE)
((VARMODE ACFLG))
(FIXSW 'FIXNUM)
(FLOSW 'FLONUM)))
(COND ((AND (NOT (ATOM LOC)) (EQ (CAR LOC) 'SPECIAL))
(SETQ ITEM (CDR LOC))))
(FIND AC)
(CPUSH1 AC () LOC)
(OUT2 '(MOVE) AC LOC))
('T (SETQ NLARG LOC)
(COND ((AND #(ACLOCP-N NLARG) (OR (NOT ACFLG) (= NLARG AC)))
(AND RMFLG (REMOVE RMFLG)) ;REMOVEs, if so requested
(CPUSH LOC)
(RETURN LOC)))
(SETQ ITEM (CONTENTS LOC))
(AND #(NUMPDLP-N NLARG) (SETQ MODE (GETMODE LOC))) ;A NUMPDL loc
(COND (ACFLG (FIND AC)
(SETQ ACFLG (EQ (CPUSH1 AC () LOC) 'PUSH)))
('T (AND (ZEROP (SETQ AC (FREENUMAC1)))
(SETQ ACFLG 'T)
(SETQ AC (FREENUMAC0)))))
(AND ACFLG ;Signifies a "PUSH" done
MODE ; and that loc is a NUMPDL
(EQ MODE (GETMODE0 AC 'T 'T)) ; so which PDL was pushed?
(SETQ LOC (ILOC0 ITEM MODE)))
(COND ((AND (OR (= LOC #(FLP0)) (= LOC #(FXP0))) ;Loc is top slot of a NUMPDL
(NOT (DVP LOC))) ; and can be popped
(OPOP AC MODE))
('T (AND (NULL MODE) ;If loc be NUMPDLP, then MODE
(SETQ MODE (GETMODE0 LOC 'T () ))) ; will already have been set
(OUT1 'MOVE AC LOC))))) ; non-null
(CONT AC (COND ((OR (NULL (CDR ITEM)) (EQ (CDR ITEM) 'DUP) (EQUAL (CDR ITEM) CNT))
(CONS (CAR ITEM) 'DUP))
((OR (NUMBERP (CDR ITEM)) (EQ (CAR ITEM) 'QUOTE)) ITEM)
((NCONS (CAR ITEM)))))
(SETMODE AC MODE)
(AND RMFLG (REMOVE RMFLG)) ;REMOVEs, if so requested
(RETURN AC)))
(DEFUN MAKEPDLNUM (ITEM AC)
(PROG (LOC MODE NEWLOC TEM)
(CPUSH AC)
(SETQ LOC #(ILOCNUM ITEM AC))
(REMOVEB ITEM)
(SETQ MODE (GETMODE LOC) NEWLOC LOC TEM () )
(COND (#(ACLOCP LOC)
(SETQ TEM (CONTENTS LOC))
(CPUSH LOC)
(CONT LOC () )
(SETQ NEWLOC (ILOC0 ITEM MODE))
(SETQ ITEM TEM)
(COND ((NULL NEWLOC) (OPUSH LOC ITEM MODE)
(SETQ NEWLOC (CONVNUMLOC 0 MODE))))
(CONT LOC (CONS (CAR ITEM) 'DUP))))
(OUT1 'MOVEI AC NEWLOC)
(COND ((NOT (VARBP (CAR ITEM)))
(AND (NOT (CLMEMBER (CAR ITEM) MODE MODELIST 'EQ))
(PUSH (CONS (CAR ITEM) MODE) MODELIST))
(PUTPROP (CAR ITEM) 'T 'UNSAFEP)))
(CONT AC (CONS (CAR ITEM) 'DUP))))
(DEFUN MAKESAFE (ITEM LOC RMFLG)
(COND
((COND ((NOT (REGADP LOC))
#(LET ((FL () ))
((LAMBDA (TAKENAC1) (SETQ FL (CPUSH 1))) #(NUMVALAC))
(LOADINNUMAC ITEM
#(NUMVALAC)
(COND ((OR (NOT (EQ FL 'PUSH))
(NOT (CAR REGACS)) ;Check (CONTENTS 1)
(NOT (EQ (GETMODE LOC) (GETMODE0 1 () 'T))))
LOC))
'REMOVEB)
(OUTPUT (COND ((EQ (OR (CAR ACSMODE) (GETMODE0 #(NUMVALAC) 'T 'T))
'FIXNUM)
'(JSP T FXCONS))
('(JSP T FLCONS))))
(RPLACA NUMACS () )) ;(CONT #(NUMVALAC) () )
'T)
((AND (NUMBERP LOC)
(NOT (AND (= LOC 1)
(NOT ATPL)
(EQ (CAR LOUT) 'JSP)
(MEMQ (CADDR LOUT)
'(FXCONS FLCONS PDLNMK))))
(UNSAFEP (CONTENTS LOC)))
(LOADAC ITEM 1 () )
(OUTPUT '(JSP T PDLNMK))
'T))
(RPLACA REGACS (SETQ ITEM (LIST (GENSYM))))
;The RPLACA is essentially a quick way to do (CONT 1 MUMBLE)
(AND (NULL RMFLG) (PUSH ITEM LDLST)) )
((EQ RMFLG 'REMOVEB) (REMOVEB ITEM))
((EQ RMFLG 'REMOVE) (REMOVE ITEM)))
ITEM)
(DEFUN MAKESURE (UNSAFEP VAR SPFL ARG LARG)
;;; VAR will never be local numvar - checked by caller
(AND (COND ((NULL (SETQ UNSAFEP (P2UNSAFEP UNSAFEP))) ;Possibly a numquantity
(COND ((REGADP LARG) () )
((NULL (SETQ LARG (ILOC0 ARG () )))
(SETQ LARG #(ILOCF ARG))
'T)
((REGADP LARG) () )
((NULL (P2UNSAFEP VAR))))) ;Here, SPFL is null
((COND (SPFL)
((ATOM UNSAFEP) (LLTV/.UNSAFE UNSAFEP)) ;Cons for X in (SETQ X Y) if both are
((MEMQ PROGN UNSAFEP)) ; some weird screw case
((DO Y UNSAFEP (CDR Y) (NULL Y) ;LLTVs, and Y is unsafe
(AND (LLTV/.UNSAFE (CAR Y)) (RETURN 'T))))))
((NOT (P2UNSAFEP VAR)))) ;No cons for local var already unsafe
(MAKESAFE ARG LARG ())))
(DEFUN LLTV/.UNSAFE (X) ;Used only by safety-checking function above
(AND (SYMBOLP X) ;Returns non-() iff X is a local NOTYPE variable
(NOT (SPECIALP X)) ; which also happens to be unsafe
(NULL (VARMODE X))
(MEMQ X UNSFLST)))
;;;(DEFUN NCDR (EXP N)
;;; (PROG ()
;;; A (COND ((OR (NULL EXP) (ZEROP N)) (RETURN EXP))
;;; ((> N 4) (SETQ N (- N 5) EXP (CDDDDR (CDR EXP))))
;;; ('T (SETQ N (1- N) EXP (CDR EXP))))
;;; (GO A)))
(DEFUN NX2LAST (X)
(COND ((NULL (CDR X)) () ) ;Remember, cdr[()]=()
((PROG (ZZ)
A (SETQ ZZ X)
(AND (NULL (CDR (SETQ X (CDR X)))) (RETURN (CAR ZZ)))
(GO A)))))
(DEFUN OJRST (TAG DONT) (OUTJ0 'JRST 0 TAG 'T DONT))
(DEFUN OPUSH (X ITEM MODE)
(PROG (TEMP OP)
(SETQ OP (COND ((AND (NULL (SETQ TEMP (REGADP X))) (NULL MODE))
(BARF X |PUSH P 7 lossage|))
((AND TEMP MODE) '(PUSH))
('PUSH)))
(COND ((AND MODE (NOT (ATOM X)) (NOT (ATOM (CAR X)))
(EQ (CADR X) 'QUOTE) (NUMBERP (SETQ TEMP (CADAR X))))
(SETQ X (LIST '% TEMP))
(SETQ OP 'PUSH)))
(OUT2 OP
(COND ((EQ MODE 'FIXNUM) (PUSH ITEM FXPDL) 'FXP)
((NULL MODE) (PUSH ITEM REGPDL) 'P)
('T (PUSH ITEM FLPDL) 'FLP))
X)))
(DEFUN OSPB (TLOC VAR)
((LAMBDA (N)
#(OUTFS N TLOC (LIST 'SPECIAL VAR)))
(COND ((NULL TLOC) (SETQ TLOC 0))
((PLUSP TLOC) 0)
('T (SETQ TLOC (ABS TLOC)) 7←33.))))
(DEFUN OPUSHS (V) (OPUSH (LIST 'SPECIAL V) (CONS V CNT) (VARMODE V)))
(DEFUN OPOP (X MODE)
((LAMBDA (PDL)
(COND ((AND (NOT ATPL)
(EQ (CAR LOUT) 'PUSH)
(EQ (CADR LOUT) PDL)
#(ACLOCP (CADDR LOUT)))
((LAMBDA (AC)
(SETQ LOUT (SETQ ATPL 'FOO))
(COND ((AND (SIGNP G X) (= X AC)) (WARN AC |PUSHPOP - OPOP|))
('T (OUT1 'MOVEM AC X))))
(CADDR LOUT)))
('T (OUT1 'POP PDL X)))
(AND MODE
#(ACLOCP X)
(SETMODE X MODE))
(SHRINKPDL 1 MODE))
#(PDLAC MODE)))
(DEFUN OUTFUNCALL (OP AC FUN)
((LAMBDA (PROP NUMFL)
(COND ((AND (OR #(NUMACP-N ARGNO) PNOB EFFS)
(OR (SETQ PROP (GET FUN 'NUMFUN))
(DO Z MODELIST (CDR Z) (NULL Z)
(AND (EQ FUN (CAAAR Z))
(NULL (CDAAR Z))
(RETURN (SETQ PROP (CDAR Z))))))
(CADR PROP))
(SETQ NUMFL 'T)
(SETQ OP (CDR (ASSQ OP '((CALL . NCALL) (JCALL . NJCALL)
(CALLF . NCALLF) (JCALLF . NJCALF)))))))
#(OUTFS OP AC (LIST 'QUOTE FUN))
(COND (NUMFL (SETMODE #(NUMVALAC) (CADR PROP))
#(NUMVALAC))
(1)))
() () ))
(DEFUN OUTG (X)
(OUTPUT (CAR X))
(DO X (CDR X) (CDR X) (NULL X)
#(OUTFS 'CAIN 1 (LIST 'QUOTE (CAAR X)))
#(OUTFS 'JUMPA 0 (CDAR X)))
(OUTPUT '(PUSHJ P *UDT))
#(OUTFS 'JUMPA 0 (CAR X))
(|Oh, FOO!|))
(DEFUN COUTPUT (X)
(AND (NOT (ATOM X)) (NOT (EQ (CAR X) 'QUOTE)) (SETQ X (MACRO-EXPAND X)))
(ICOUTPUT X))
(DEFUN ICOUTPUT (X)
(COND (FASLPUSH (PUSH X LAPLL))
((ATOM X)
(COND ((EQ X GOFOO) (TERPRI)) ;Signal for CR
((EQ X NULFU) (PRINC '| |)) ;Signal for SPACE
((NULL X) (PRINC '|() |))
('T (PRIN1 X))))
((AND (EQ (CAR X) 'QUOTE) (NULL (CDDR X)))
(COND ((AND (NOT (ATOM (CADR X)))
(OR (EQ (CAADR X) SQUID) (EQ (CDADR X) GOFOO)))
((LAMBDA (Y)
(COND ((OR (EQ (CDR Y) GOFOO)
(NOT (EQ (CADR Y) MAKUNBOUND)))
(PRINC '/(EVAL/ )
(ICOUTPUT (CAADR X))
(PRINC '/)))
('T (PRINC 'MAKUNBOUND))))
(CADR X)))
('T (PRINC '|'|) (ICOUTPUT (CADR X)))))
('T (PROG ()
(PRINC '|(|)
A (ICOUTPUT (CAR X))
(COND ((NULL (SETQ X (CDR X))))
((ATOM X) (PRINC '| . |) (PRIN1 X))
('T (PRINC '| |) (GO A)))
(PRINC '|)|) )))
() )
(DEFUN OUTPUT (X)
((LAMBDA (ATP)
(COND ((COND ((AND ATP (NOT (EQ X 'FOO))))
((NOT ATPL) (NOT (EQ (CAR LOUT) 'JRST)))
((NOT (EQ LOUT 'FOO)))
((NOT ATPL1) (NOT (EQ (CAR LOUT1) 'JRST)))
(T))
(COND ((EQ LOUT 'FOO) (SETQ LOUT X ATPL ATP))
('T (COND ((EQ LOUT1 'FOO))
((PROG2 (AND (NOT ATPL1)
(EQ (CAR LOUT1) 'JUMPA)
(SETQ LOUT1 (CONS 'JRST (CDR LOUT1))))
() ))
(FASLPUSH (PUSH LOUT1 LAPLL))
('T (ICOUTPUT GOFOO)
(ICOUTPUT LOUT1)
(ICOUTPUT NULFU)))
(SETQ LOUT1 LOUT ATPL1 ATPL LOUT X ATPL ATP))))))
(ATOM X)))
(DEFUN OUT1 (A B C)
#(LET (Z X ACP (N@P (ATOM A)) (TPC (TYPEP C)) (N 0))
;;; A might be "MOVE" or "(MOVE)", the latter meaning MOVE indirect
;;; B is usually 0 - 17, or maybe "P", or "T"
;;; C is N for slotloc N
;;; "FOO" for symbol FOO
;;; "(SPECIAL FOO)" for special variable FOO
;;; "(QUOTE FUN)" for direct reference to "FUN", as in (CALL 1 'FUN)
;;; "((QUOTE THING))" for loading quotified stuff,
;;; as in (MOVEI 1 'THING), or (PUSH P (% 0 0 'THING))
(SETQ ACP (AND (EQ TPC 'FIXNUM) (PLUSP (SETQ N C))))
(SETQ X
(COND ((OR (MEMQ TPC '(FIXNUM SYMBOL)) (SYMBOLP (CAR C)))
(COND ((AND N@P ACP #(REGACP-N N) (SETQ X (GET A 'IMMED)))
(SETQ N@P () ) X)
(N@P A)
((CAR A))))
('T (SETQ C (CAR C)) ;C WAS "((QUOTE THING))"
(COND ((SETQ X (COND (N@P (GET A 'IMMED)) ((CDR A))))
(SETQ N@P 'T)
X)
('T (SETQ C (LIST '% 0 0 C))
(COND (N@P A) ((CAR A))))))))
(SETQ Z (COND ((AND ACP (NOT N@P)) (SETQ N@P 'T) (LIST 0 C))
((AND (NOT ACP) (EQ TPC 'FIXNUM))
(COND (#(NUMPDLP-N N)
(COND (#(FLPDLP-N N) (CONS (- C #(FLP0)) '(FLP)))
('T (CONS (- C #(FXP0)) '(FXP)))))
((CONS C '(P)))))
((NCONS C))))
(SETQ Z (CONS B (COND (N@P Z) ((CONS '@ Z)))))
(OUTPUT (CONS X Z)))
() () () ))
(DEFUN OUT3 (OP ACX AD) (COND ((REGADP AD) (OUT2 OP ACX AD)) ((OUT1 (CAR OP) ACX AD))))
(DEFUN OUT2 (OP ACX AD)
((LAMBDA (TYPE NEWAD)
(COND ((OR (ATOM OP) (ATOM AD) (ATOM (CAR AD))
(NOT (EQ (CAAR AD) 'QUOTE))
(NOT (MEMQ (SETQ TYPE (TYPEP (SETQ NEWAD (CADAR AD))))
'(FIXNUM FLONUM))))
(OUT1 OP ACX AD))
('T ((LAMBDA (II NEWOP)
(COND ((AND (EQ TYPE 'FIXNUM)
(SETQ NEWOP (GET (CAR OP) 'IMMED))
(COND ((AND (NOT (< (SETQ II NEWAD) 0)) (< II 1←18.)))
((AND (LESSP -1←18. II 0)
(SETQ NEWOP (GET NEWOP 'MINUS)))
(SETQ NEWAD (- II))
'T))))
((AND (EQ TYPE 'FLONUM)
(ZEROP (LSH NEWAD 18.))
(SETQ NEWOP (GET (CAR OP) 'FLOATI)))
(SETQ II (LSH NEWAD 0))
(COND ((AND (> II 0)
(MEMQ NEWOP '(FDVRI FMPRI))
(ZEROP (BOOLE 1 (LSH NEWAD 0) 67108863.))) ;377777777[8]
(SETQ II (- (LSH II -27.) 129.))
(AND (EQ NEWOP 'FDVRI) (SETQ II (- II)))
(SETQ NEWOP 'FSC))
('T (SETQ II (LSH II -18.))))
(SETQ NEWAD II))
('T (SETQ NEWOP (CAR OP) NEWAD (LIST '% NEWAD))))
#(OUTFS NEWOP ACX NEWAD))
0 () ))))
() () ))
(DEFUN OUT3FIELDS (Z Y X) (OUTPUT (LIST X Y Z)))
(DEFUN OUT4FIELDS (V Z Y X) (OUTPUT (LIST X Y Z V)))
(DEFUN OUT5FIELDS (W V Z Y X) (OUTPUT (LIST X Y Z V W)))
(DEFUN OUTJ (INST LARG TAG)
(AND (NOT #(ACLOCP LARG)) (BARF LARG |Not ac - OUTJ|))
(CLEARVARS)
(OUTJ0 INST LARG TAG () LARG))
(DEFUN OUTJ0 (INST LARG TAG JSP DONT)
(PROG (TEM SVSLT YAGPV AC LARGSLOTP NLARG)
(SETQ LARGSLOTP (NUMBERP LARG))
(SETQ AC 0 NLARG (COND (LARGSLOTP LARG) (0)))
(AND (AND (NOT JSP) LARGSLOTP #(PDLLOCP-N NLARG))
(SETQ SVSLT (CONTENTS LARG)))
(AND (RSTD TAG
(COND (#(ACLOCP DONT) DONT) (0))
(COND ((AND LARGSLOTP #(ACLOCP-N NLARG)) LARG) (0)))
SVSLT
(SETQ LARG #(ILOCF SVSLT))
(SETQ NLARG (COND ((SETQ LARGSLOTP (NUMBERP LARG)) LARG) (0))))
(COND ((AND (NOT JSP)
(COND ((NOT LARGSLOTP)
(EQ (CAR LARG) 'SPECIAL))
((AND SVSLT (NULL (CDR SVSLT)) #(REGACP-N NLARG))
(OR (VARBP (CAR SVSLT))
(ASSQ (CAR SVSLT) SPLDLST))))
(SETQ YAGPV (MEMQ () REGACS)))
(SETQ AC (- #(NACS+1) (LENGTH YAGPV)))
(CONT AC (CONS (COND ((NOT (ATOM LARG)) (CADR LARG))
((CAR SVSLT))) 'DUP))))
(COND ((OR JSP (NOT LARGSLOTP) (NOT #(ACLOCP-N NLARG))) () )
(#(REGACP-N NLARG)
(AND (SETQ TEM (ASSQ INST '((JUMPE () ((QUOTE () )))
(JUMPN ((QUOTE () )) () ))))
(CADDR TEM)
(SETQ SVSLT (CONTENTS LARG))
(RPLACA SLOTX (CAADDR TEM))))
(#(NUMACP-N NLARG)
(AND (MEMQ INST '(SOJN SOJE))
(RPLACA SLOTX () ))))
;Set up the acs of the level of TAG, assuming that the jump is taken
; but dont worry about prog tags
(AND (SETQ YAGPV (GET TAG 'LEVEL))
(ACMRG (CAR YAGPV) (CADR YAGPV) (CADDR YAGPV) REGACS NUMACS ACSMODE
(COND ((NOT (GET TAG 'USED)) (PUTPROP TAG 'T 'USED)))))
; Jump falls through, so reset SLOTLIST accordingly
(COND (TEM (FIND LARG)
(COND ((CADR TEM) (RPLACA SLOTX (CAADR TEM)))
(SVSLT (RPLACA SLOTX SVSLT)))))
(SETQ DONT (COND (JSP () )
((AND LARGSLOTP #(ACLOCP-N NLARG))
(COND ((AND #(NUMACP-N NLARG)
(NOT (ATOM INST))
(MEMQ (CAR INST) '(TRNN TRNE TLNN TLNE)))
(OUT1 (GET (CAR INST) 'CONV) LARG (CDR INST))
(SETQ INST 'JUMPA))))
('T (OUT1 (COND ((EQ INST 'JUMPE) 'SKIPN) ('SKIPE)) AC LARG)
(SETQ INST 'JUMPA))))
#(OUTFS INST
(COND (DONT 0) (LARG))
(COND ((AND (NOT ATPL)
JSP
(EQ INST 'JRST)
(SETQ TEM (GET TAG 'PREVI))
(EQUAL LOUT TEM))
(SETQ LOUT (SETQ ATPL 'FOO))
(LIST TAG -1))
(TAG)))
(RETURN LARG))) ; RETURN LOC OF ARG
; OUTTAG returns non-null iff TAG was used
(DEFUN OUTTAG (X)
(COND ((AND X (GET X 'USED))
(CLEANUPSPL () )
(CLEARVARS)
((LAMBDA (LL)
(COND (LL (RESTORE LL)
(ACMRG REGACS NUMACS ACSMODE (CAR LL) (CADR LL) (CADDR LL) () ))
('T #(CLEARALLACS))))
(LEVEL X))
(OUTTAG0 X)
X)))
(DEFUN OUTTAG-TO-LEVEL (TAG)
(SLOTLISTSET (LEVEL TAG))
(OUTTAG0 TAG))
(DEFUN OUTTAG0 (X)
((LAMBDA (V)
(COND ((AND (AND (NOT ATPL) (NOT ATPL1)) ; JUMPX AC,TG
(MEMQ (CAR LOUT) '(JRST JUMPA))
(EQ X (CADDR LOUT1)) ; JRST 0 TG1
(NOT (EQ (CAR LOUT1) 'JUMPA)) ;TG: . . .
(SETQ V (GET (CAR LOUT1) 'CONV))) ;Turns into JUMP[X'] AC,TG1
(SETQ LOUT (LIST V (CADR LOUT1) (CADDR LOUT)))
(SETQ LOUT1 (SETQ ATPL1 'FOO)))) ;ATPL is already ()
(COND ((NOT ATPL)
(AND (NOT (EQ (CAR LOUT) 'JUMPA))
(OR (EQ (CAR LOUT) 'JRST) ; JUMPX AC,TG
(GET (CAR LOUT) 'CONV)) ;TG: .. .
(EQ X (CADDR LOUT)) ;Turns into just TG:
(SETQ LOUT (SETQ ATPL 'FOO))))
((NOT (EQ LOUT 'FOO)) ; JUMPX AC,TG
(AND (NOT ATPL1) ;TG1:
(NOT (EQ (CAR LOUT1) 'JUMPA))
(OR (EQ (CAR LOUT1) 'JRST) ;TG: . . .
(GET (CAR LOUT1) 'CONV)) ;Becomes merely the two tags
(EQ X (CADDR LOUT1))
(SETQ LOUT1 (SETQ ATPL1 'FOO)))))
(OUTPUT X))
() ))
;;; Note how the lines (EQ X (CADDR LOUT1)) and (EQ X (CADDR LOUT))
;;; Prevent taking clauses like (SKIPN 0 FOO) or (CAIE AC FOO)
;;; JUMPx and JUMP[x'] are invertible conditions
(DEFUN PROGHACSET (SPFL EXP)
;;; Special hac for (LAMBDA (SVAR1) (PROG (SVAR2) :))
;;; or for (LAMBDA (SVAR1) (COMMENT :) : (PROG (SVAR2) : ))
;;; to allow only one call to SPECBIND
(COND ((AND SPFL
(COND ((EQ (CAR EXP) 'PROG))
((AND (EQ (CAR EXP) PROGN)
(EQ (CAADR EXP) 'PROG)
(NULL (GCDR (FUNCTION
(LAMBDA (Z)
(NOT (MEMQ (CAAR Z) '(COMMENT DECLARE)))))
(CDDR EXP))))
(SETQ EXP (CADR EXP))
'T))
(GCDR (FUNCTION (LAMBDA (Z) (SPECIALP (CAR Z)))) (CADDR (CDDDR EXP))))
(SETQ SFLG 'T)
() )
('T (SETQ SFLG () ) SPFL)))
(DEFUN QNILP (X) (AND (NOT (ATOM X)) (EQ (CAR X) 'QUOTE) (NULL (CADR X))))
(DEFUN Q0P+0P (X)
(AND (NOT (ATOM X)) (EQ (CAR X) 'QUOTE) (SETQ X (CADR X)))
((LAMBDA (TYPE)
(COND ((AND (EQ TYPE 'FLONUM) (= X 0.0)) 0.0)
((AND (EQ TYPE 'FIXNUM) (= X 0)) 0)))
(TYPEP X)))
(DEFUN Q1P+1P-1P (X)
(AND (NOT (ATOM X)) (EQ (CAR X) 'QUOTE) (SETQ X (CADR X)))
((LAMBDA (TYPE)
(COND ((EQ TYPE 'FLONUM)
(COND ((= X 1.0) 1.0) ((= X -1.0) -1.0)))
((EQ TYPE 'FIXNUM)
(COND ((= X 1) 1) ((= X -1) -1)))))
(TYPEP X)))
(DEFUN QNP (X) (AND (NOT (ATOM X)) (EQ (CAR X) 'QUOTE) (NUMBERP (CADR X))))
(DEFUN REGADP (X)
#(LET ((N 0))
(OR (NOT (NUMBERP X)) ;(SPECIAL A), ((QUOTE 5))
#(REGADP-N (SETQ N X))))) ;NUMWORLD
(DEFUN REMOVEB (X) (OR (NULL X) (REMOVE X) (REMOVS X)))
(DEFUN REMOVE (X) ;REMOVE DOES NOT TAKE CARCDR'INGS OFF THE SPLDLST
(AND X
(SETQ LDLST (DELQ X LDLST))
(COND ((EQ (CAR X) 'QUOTE))
((NUMBERP (CDR X))
(REMOVS X)
'T))))
(DEFUN REMOVS (X)
(AND X
SPLDLST
(SETQ X (CLMEMBER (CAR X)
(CDR X)
SPLDLST
(COND ((NUMBERP (CDR X)) '=) ('ASSQ))))
(RPLACA X () )))
(DEFUN RESTORE (X)
(AND X
(DO ((MODES '(() FIXNUM FLONUM) (CDR MODES)) ;Cycles thru pdls REGPDL FXPDL FLPDL
(RSL)
(XS (CDDDR X) (CDR XS)))
((OR (NULL MODES) (NULL XS)) RSL)
(PROG (RSTNO N PDLTP P X MODE)
(SETQ X (CAR XS) MODE (CAR MODES))
(SETQ P #(PDLAC MODE) PDLTP #(PDLGET MODE))
(AND (MINUSP (SETQ RSTNO (DIFFERENCE (LENGTH PDLTP) (LENGTH X))))
(BARF (LIST X '/
(SLOTLISTCOPY) ) |RESTORE lossage|))
A1 (AND (ZEROP RSTNO) (RETURN RSL))
(SETQ N 0 RSL 'T)
A2 (COND ((NOT (OR (NULL PDLTP)
(= N RSTNO)
(DVP1 PDLTP (CONVNUMLOC 0 MODE))))
(SETQ N (ADD1 N))
(SETQ PDLTP (CDR PDLTP))
(COND ((EQ MODE 'FIXNUM) (SETQ FXPDL PDLTP))
((NULL MODE) (SETQ REGPDL PDLTP))
('T (SETQ FLPDL PDLTP)))
(GO A2)))
; So subtract off as much as possible and pop top PDL slot
; to some safe slot. For safe slots try first those with the
; same item name on the back of the PDL, and then those
; of the acs; as a last resort try FREEAC.
(SETQ RSTNO (DIFFERENCE RSTNO N))
; (AND (EQ LOUT 'FOO) (SETQ LOUT LOUT1) (SETQ LOUT1 'FOO))
; Above instruction had to be removed because of JRST followed FOO case
(AND (NOT ATPL)
(EQ (CAR LOUT) 'SUB) ;This converts two restores of
(EQ (CADR LOUT) P) ;SUB P,[N,,N] - SUB P,[M,,M]
(SETQ N (PLUS N (CADDDR (CADDR LOUT))) ; into one
LOUT (SETQ ATPL 'FOO))) ;SUB P,[N+M,,N+M]
(AND (NOT ATPL1)
(EQ (CAR LOUT1) 'SUB)
(EQ (CADR LOUT1) P)
(OR (EQ LOUT 'FOO)
(AND (NOT ATPL)
(OR (EQ (CAR LOUT) 'SUB)
(EQ (CAR LOUT) 'PUSHJ)
(AND (EQ (CAR LOUT) 'JSP)
(NOT (EQ (CADDR LOUT) 'PDLNMK))))))
(SETQ N (PLUS N (CADDDR (CADDR LOUT1)))
LOUT1 LOUT ATPL1 ATPL LOUT (SETQ ATPL 'FOO)))
(AND (COND ((ZEROP N) () )
((AND (NOT ATPL) (EQ (CAR LOUT) 'PUSH))
(AND (EQ (CADR LOUT) P)
(PROG2 (SETQ LOUT (SETQ ATPL 'FOO)) 'T)))
((AND (AND (NOT ATPL) (NOT ATPL1))
(EQ (CAR LOUT1) 'PUSH)
(EQ (CAR LOUT) 'SUB))
(AND (EQ (CADR LOUT1) P)
(PROG2 (SETQ LOUT1 (SETQ ATPL1 'FOO)) 'T))))
(SETQ N (1- N)))
(AND (NOT (ZEROP N)) #(OUTFS 'SUB P (LIST '% 0 0 N N)))
(AND (ZEROP RSTNO) (RETURN RSL))
((LAMBDA (N BESTCNT BESTLOC FL TEM)
(COND ((AND (SETQ TEM (VARBP (CAR FL))) (NOT (EQ TEM 'SPECIAL))) ;localvarp
(DO ((L (FIND N) (CDR L)) (V X (CDR V)))
((NULL V))
(COND ((NULL (CAR V)))
((NOT (EQ (CAAR V) (CAAR PDLTP))))
((NULL (CDAR V))
(COND ((AND (EQ (CAAR L) (CAAR V))
(EQ (CDAR L) 'OHOME)))
((NOT (DVP1 L N)))
((NOT (AND (MEMQ (CDAR L) '(() OHOME))
(VARBP (CAAR L))))
(SETQ BESTLOC (FREACB))
(OUT1 'MOVE BESTLOC N)
(CONT BESTLOC (CONTENTS N))
(CONT N () ))
((BARF N |Someones in my home - RESTORE |)))
(RETURN (SETQ BESTCNT (SETQ BESTLOC N))))
((OR (AND (SETQ FL (NUMBERP (CDAR V)))
(GREATERP (CDAR V) BESTCNT))
(ZEROP BESTCNT))
(SETQ BESTLOC N)
(AND FL (SETQ BESTCNT (CDAR V)))))
(SETQ N (SUB1 N))))
(#(ACLOCP (SETQ FL (ILOC0 FL MODE)))
(SETQ BESTLOC FL BESTCNT 1)))
(SETQ FL (CAR PDLTP))
(COND ((AND (ZEROP BESTCNT)
(NOT ATPL)
(EQ (CAR LOUT) 'PUSH)
#(ACLOCP (SETQ BESTLOC (CADDR LOUT))))
(WARN (LIST BESTLOC N) |PUSHPOP - RESTORE|)
(SETQ LOUT (SETQ ATPL 'FOO))
(SHRINKPDL 1 MODE))
('T (AND (ZEROP BESTCNT)
(COND ((NULL MODE) (SETQ BESTLOC (FREACB)))
((NOT (ZEROP (SETQ BESTLOC (FREENUMAC1)))))
('T (BARF () |Not enuf NUMACS - RESTORE|))))
(CONT BESTLOC FL)
(OPOP BESTLOC MODE))))
(CONVNUMLOC (MINUS RSTNO) MODE) 0 0 (CAR PDLTP) () )
(SETQ RSTNO (SUB1 RSTNO))
(SETQ PDLTP (COND ((EQ MODE 'FIXNUM) FXPDL)
((NULL MODE) REGPDL)
(FLPDL)))
(GO A1)))))
(DEFUN RST (X)
; Restore slotlist to level of a tag,
; Valuable stuff should not be in accs
; If value is non-null, it must be a slotlist level
(AND X (RESTORE (LEVEL X))))
(DEFUN RSTD (TAG A1 A2) ;Restore, but dont take the
(DECLARE (FIXNUM A1 A2))
(PROG (SV1 SV2 RSL) ; accumulators A1 and A2 for temps
(COND ((ZEROP A1)
(AND (ZEROP A2) (RETURN (RST TAG)))
(SETQ A1 A2 A2 0)))
(AND (= A1 A2) (SETQ A2 0))
(SETQ SV1 (CONTENTS A1))
(RPLACA SLOTX '(NIL . TAKEN))
(COND ((NOT (ZEROP A2))
(SETQ SV2 (CONTENTS A2))
(RPLACA SLOTX '(NIL . TAKEN))))
(SETQ RSL (RST TAG))
(CONT A1 SV1)
(AND (NOT (ZEROP A2)) (CONT A2 SV2))
(RETURN RSL)))
(DEFUN RETURNTAG NIL
((LAMBDA (TAG)
#(OUTFS 'MOVEI 'T TAG)
(OPUSH 'T '(NIL . TAKEN) () )
TAG)
(GENSYM)))
(DEFUN SETMODE (AC MODE) (RPLACA #(ACSMODESLOT AC) MODE))
(DEFUN SHRINKPDL (N MODE)
(CASEQ MODE
(NIL (SETQ REGPDL #(NCDR REGPDL N)))
(FIXNUM (SETQ FXPDL #(NCDR FXPDL N)))
(FLONUM (SETQ FLPDL #(NCDR FLPDL N)))))
(DEFUN STRETCHPDL (N MODE)
(DO ((I N (1- I)) (L () (CONS '(NIL . TAKEN) L)))
((ZEROP I)
(CASEQ MODE
(NIL (SETQ REGPDL (NCONC L REGPDL)))
(FIXNUM (SETQ FXPDL (NCONC L FXPDL)))
(FLONUM (SETQ FLPDL (NCONC L FLPDL)))))))
(DEFUN SLOTLISTCOPY ()
(LIST (APPEND REGACS () ) (APPEND NUMACS () ) (APPEND ACSMODE () )
(APPEND REGPDL () ) (APPEND FXPDL () ) (APPEND FLPDL () )))
(DEFUN SLOTLISTSET (L)
(SETQ REGACS (CAR L) NUMACS (CADR L) ACSMODE (CAR (SETQ L (CDDR L)))
REGPDL (CADR L) FXPDL (CAR (SETQ L (CDDR L))) FLPDL (CADR L)))
;;; Returns "(SPECIAL x)" if "x" is indeed SPECIAL
(DEFUN SPECIALP (X)
(COND ((GET X 'SPECIAL))
((NULL SPECVARS) () )
((CDR (ASSQ X SPECVARS)))))
(DEFUN STRTIBLE (X)
(OR (NULL X)
((LAMBDA (TYP)
(OR (MEMQ TYP '(SYMBOL FLONUM))
(AND (EQ TYP 'LIST)
(STRTIBLE (CAR X))
(STRTIBLE (CDR X)))))
(TYPEP X))))
(DEFUN UNSAFEP (X) ;Called only on the output of "COMP"
(COND ((NULL X) () ) ;Must coordinate this function with "VARBP"
((EQ (SETQ X (CAR X)) 'QUOTE) () )
(((LAMBDA (Y)
(COND ((NULL Y) () ) ;??
((EQ (CAR Y) 'UNSAFEP)) ;Unsafe GENSYM
((EQ (CAR Y) 'OHOME) ;AHA! Local var
(COND ((MEMQ X UNSFLST)) ;LLTV unsafe
((VARMODE X)))) ;NUMVAR unsafe
('T () ))) ;Specs are safe
(GETL X '(SPECIAL OHOME UNSAFEP))))))
(DEFUN VARBP (X)
(COND ((NULL X) () )
((NOT (SYMBOLP X)) (BARF X |Not a SYMBOL - VARBP|))
(((LAMBDA (Y)
(COND ((NULL Y) (COND ((ASSQ X SPECVARS) 'SPECIAL)))
((EQ (CAR Y) 'SPECIAL) 'SPECIAL)
('T)))
(GETL X '(SPECIAL OHOME))) )))
(DEFUN VARMODE (VAR)
(COND ((NULL VAR) () )
((CDR (COND ((ASSQ VAR MODELIST)) ('( () ) ))))
((GET VAR 'NUMVAR))))
;;; End of PHASE2 auxilliary functions
(COMMENT PHASE1 FUNCTIONS)
(DEFUN P1 (X)
(PROG (FTYP 2NDP Z Y TEM MODE)
P1-START
(COND ((NULL X) (GO P1NIL))
((EQ X 'T) (RETURN (COND (ARITHP '('T)) (''T))))
((MEMQ (SETQ Z (TYPEP X)) '(BIGNUM FIXNUM FLONUM))
(SETQ X (LIST 'QUOTE X) MODE (COND ((EQ Z 'BIGNUM) () ) (Z)))
(GO P1XIT))
((EQ Z 'SYMBOL)
(COND ((SETQ Z (ASSQ X RNL))
(SETQ X (CDR Z))
(GO P1-START)))
(SETQ CNT (ADD1 CNT))
(P1SPECIAL X)
(AND ARITHP (SETQ MODE (VARMODE X)))
(GO P1XIT))
((NOT (EQ Z 'LIST))
(PDERR X |Random piece of data - () will be substituted|)
(GO P1NIL))
((EQ (SETQ Z (TYPEP (CAR X))) 'LIST)
(COND ((EQ (CAAR X) 'LAMBDA) (RETURN (P1LAM (CAR X) (CDR X))))
((EQ (CAAR X) 'LABEL)
(PDERR X |LABEL is no longer supported|)
(GO P1NIL))
((EQ (CAAR X) CARCDR)
(SETQ X (LIST (CAR X) (P1VN (CADR X))))
(GO P1XIT))
((MEMQ (CAAR X) '(QUOTE FUNCTION))
(SETQ X (CONS (CADAR X) (CDR X)))
(GO P1-START))
((EQ (CAAR X) COMP)
(P1SQV PROGN)
(SETQ X ((LAMBDA (EFFS ARITHP KTYPE PNOB)
(RPLACD (CDAR X) (P1 (CDDAR X)))
(COND ((> (LENGTH (CDR X)) #(NACS))
(P1FAKE X))
('T (CONS (CAR X) (MAPCAR 'P1 (CDR X))))))
() () () 'T))
(SETQ MODE (AND (MEMQ (CADAR X) '(FIXNUM FLONUM)) (CADAR X)))
(GO P1XIT))
((EQ (CAAR X) MAKUNBOUND) (GO P1XIT))
((NOT (EQ (SETQ Z (P1MACROGET (CAR X))) NULFU))
(SETQ X (CONS Z (CDR X)))
(GO P1-START))
('T (P1SQV PROGN)
(SETQ X ((LAMBDA (EFFS ARITHP KTYPE PNOB)
(SETQ Z (P1 (CAR X)) ARITHP () )
(COND ((CDR Z)
(PDERR X |Computed function cant be numeric|)
(GO P1NIL))
('T (WARN X |Computed functions are not generally supported,/
This code is being rewritten using FUNCALL|)))
(AND (ATOM (CAR Z))
(SYSP (CAR Z))
(SETQ X (CONS (CAR Z) (CDR X)))
(GO P1-START))
(SETQ X (CONS (CONS COMP (CONS 'FUNCALL (CAR Z)))
(MAPCAR 'P1 (CDR X)))))
() 'T () 'T))
(GO P1XIT))))
((NOT (EQ Z 'SYMBOL))
(PDERR X |Unlikely crufft used in functional position|)
(GO P1NIL))
((OR (EQ (CAR X) 'T) (NULL (CAR X)))
(WARN X |T and NIL are verry poor choices for function names -
you will most likely lose badly!|))
((EQ (CAR X) 'QUOTE) ;Certain QUOTEs are trivial
(COND ((OR (NULL (CDR X)) (CDDR X)) (GO WNA))
((OR (EQ (CADR X) 'T) (NULL (CADR X)))
(SETQ X (CADR X))
(GO P1-START))
((MEMQ (SETQ TEM (TYPEP (CADR X))) '(FIXNUM FLONUM))
(SETQ MODE TEM)))
(GO P1XIT))
((EQ (CAR X) NULFU) (GO P1-CALL)) ;Placeholder for pseudo-SUBR
((NOT (EQ (SETQ Z (P1MACROGET X)) NULFU)) (SETQ X Z) (GO P1-START)));Try again after MACRO expansion
;Here, we analyze a symbol used in functional position,
; obtaining the relevant information from property list flags
B-? (SETQ FTYP (FUNTYP-DECODE (CAR X)))
(COND ((NULL FTYP)
;Each wing of this COND will GO someplace
(COND ((GET (CAR X) '*ARRAY) (GO P1-CALL))
((EQ (CAR X) GOFOO) (GO P1XIT))
;;; ((SETQ Y (ASSQ (CAR X) RNL))
;;; (SETQ X (CONS (CDR Y) (CDR X)))
;;; (GO P1-START))
('T (P1SQV PROGN)
(AND (MEMQ (CAR X) BVARS)
#(WARN X |Bound variable used as Function name|))
;;; (COND ((AND (NULL NFUNVARS)
;;; (OR (SETQ TEM (SPECIALP (CAR X)))
;;; (MEMQ (CAR X) BVARS)))
;;; (COND ((NOT (SETQ Y (ASSQ (CAR X) FFVL)))
;;; (COND (TEM #(WARN (CAR X) |Used as free functional variable|))
;;; ('T (CKCFV (CAR X))
;;; #(WARN (CAR X) |Used as bound functional variable|)))
;;; (PUSH (LIST (CAR X) TOPFN) FFVL))
;;; ((NOT (MEMQ TOPFN (CDR Y)))
;;; (RPLACD Y (CONS TOPFN (CDR Y)))))
;;; (SETQ X (CONS (CONS COMP (CONS 'FUNCALL (CAR X))) (CDR X)))
;;; (GO P1-START)))
(PUSH (CAR X) UNDFUNS)
(PUTPROP (CAR X)
'T
(COND ((> (SETQ Z (LENGTH (CDR X))) #(NACS))
(SETQ Z (CONS Z Z))
'*LEXPR)
('T (SETQ Z (CONS () Z))
'*EXPR)))
(P1ACK (CAR X) () Z (CDR Z))
(COND ((CAR Z) (RETURN (P1FAKE X)))
('T (GO P1-CALL))) )) )
((EQ FTYP 'JSP)
(AND (P1ACK (CAR X) 'SUBR () (CDR X)) (GO WNA))
(GO P1-CALL))
((EQ FTYP 'CARCDR) (RETURN (P1CARCDR X)))
((MEMQ FTYP '(*EXPR *FEXPR *LEXPR))
(P1SQV PROGN)
(COND ((EQ FTYP '*EXPR)
((LAMBDA (ZZ)
(COND ((OR (> ZZ #(NACS)) (GET (CAR X) '*LEXPR))
(LREMPROP (CAR X) '(*EXPR *LEXPR))
(PUTPROP (CAR X) 'T '*LEXPR)
(AND (P1ACK (CAR X) 'LSUBR (CONS ZZ ZZ) ZZ)
(GO WNA))
(RETURN (P1FAKE X)))
((P1ACK (CAR X) 'SUBR (CONS () ZZ) ZZ)
(GO WNA))
('T (GO P1-CALL))))
(LENGTH (CDR X))))
((EQ FTYP '*LEXPR) (RETURN (P1FAKE X)))
((EQ FTYP '*FEXPR) (RETURN (P1MODESET X)))) )
((EQ FTYP 'SUBR)
(AND (MEMQ (CAR X) '(SORT SORTCAR))
(SETQ Y (P1FUNGET (CADDR X)))
(SETQ X (LIST (CAR X) (CADR X) Y)))
(GO DISPATCH))
((MEMQ FTYP '(FSUBR LSUBR)) (GO DISPATCH))
('T (BARF () |Bad function type - P1|) ))
B-SUBR (SETQ 2NDP (SETQ FTYP 'SUBR)) (GO DISPATCH)
B-LSUBR (SETQ 2NDP (SETQ FTYP 'LSUBR)) (GO DISPATCH)
B-FSUBR (SETQ 2NDP (SETQ FTYP 'FSUBR)) (GO DISPATCH)
DISPATCH ;It is assumed that FTYP will be among SUBR, FSUBR, and LSUBR
(SETQ TEM () Z () )
(COND ((AND (NOT 2NDP) ;"2NDP" non-null means
(OR (SETQ TEM (GET (CAR X) 'ARITHP)) ; already half dispatched
(SETQ Z (GET (CAR X) 'NUMBERP)))) ;Throw numeric stuff to P1ARITH
(AND (P1ACK (CAR X) FTYP () (CDR X)) (GO WNA))
(AND (AND Z (MEMQ (CAR X) '(EQ EQUAL)))
(COND ((OR (NULL (CADR X)) (QNILP (CADR X))) ;But trap-out "(EQ MUMBLE () )"
(SETQ TEM (CADDR X))
'T)
((OR (NULL (CADDR X)) (QNILP (CADDR X)))
(SETQ TEM (CADR X))
'T))
(PROG2 (SETQ X (LIST 'NULL TEM)) (GO B-SUBR)))
(RETURN (P1ARITH X TEM Z)))
((EQ FTYP 'FSUBR)
(COND ((EQ (CAR X) 'SETQ) (RETURN (P1SETQ X)))
((EQ (CAR X) 'PROG) (RETURN (P1PROG (CDR X))))
((EQ (CAR X) 'COND) (RETURN (P1COND (CAR X) (CDR X))))
((MEMQ (CAR X) '(AND OR))
(COND ((NULL (CDDR X))
(WARN X |There are not two or more clauses here - do you really want this?|)
(SETQ X (COND ((CDR X) (CADR X))
((EQ (CAR X) 'AND))))
(GO P1-START))
(EFFS (RETURN (P1COND (CAR X) (CDR X))))
((EQ (CAR X) 'OR) (SETQ TEM (MAPCAR 'NCONS (CDR X))))
('T (SETQ TEM (L2F (CDR X)))
(SETQ TEM (LIST (LIST (COND ((NULL (CDDR TEM)) (CADR TEM))
((CONS 'AND (CDR TEM))))
(CAR TEM))))))
(RETURN (P1COND 'COND TEM)))
((EQ (CAR X) 'GO) (SETQ X (P1GO X)) (GO P1XIT))
((EQ (CAR X) 'DO) ;DO expands into a LAMBDA application
(SETQ X (P1DO (SETQ TEM X))) ; and hence this must be dispatched
(AND (NULL X) (DBARF TEM |Bad DO format|))
(GO P1-START)) ; from the start again.
((EQ (CAR X) 'CASEQ)
(SETQ X (P1CASEQ (SETQ TEM X))) ;Might expand into a COND, or
(AND (NULL X) (DBARF TEM |Bad CASEQ format|))
(GO P1-START)) ; a LAMBDA application
((EQ (CAR X) 'PUSH) ;Must have PUSH expand into
(SETQ X (P1-PP X)) ; a SETQ of something
(GO B-FSUBR))
((EQ (CAR X) 'POP) ;Must have POP expand into
(SETQ X (P1-PP X)) ; a PROG2 of something
(GO B-LSUBR))
((EQ (CAR X) 'STORE)
((LAMBDA (EFFS ARITHP KTYPE PNOB)
(SETQ Z (P1 (CADDR X)))
(SETQ MODE (CDR Z) Z (CAR Z) ARITHP () )
(AND KTYPE MODE (NOT (EQ MODE KTYPE)) (P1ARG-WRNTYP X))
(SETQ X (LIST 'STORE (P1 (CADR X)) Z)))
() 'T (CDR (NUMTYP (CADR X) () )) () )
(GO P1XIT))
((COND ((EQ (CAR X) 'ARRAYCALL)
(AND (NOT ARRAYOPEN)
(SETQ X (CONS (CONS COMP (CONS 'FUNCALL (CADDR X))) (CDDDR X)))
(GO P1-START))
(AND (NULL (CDDDR X)) (GO WNA))
'T)
((MEMQ (CAR X) '(SUBRCALL LSUBRCALL))
(P1SQV PROGN)
'T))
(COND ((OR (NULL (CDR X)) (NULL (CDDR X))) (GO WNA))
((EQ (SETQ TEM (TYPEP (CADR X))) 'SYMBOL))
((AND (EQ TEM 'LIST) (NOT (EQ (CADDR X) 'QUOTE))))
('T (PDERR X |Wrong functional designator|)))
(COND ((SETQ MODE (ASSQ (CADR X) COMAL))
(SETQ MODE (AND (NOT (EQ (CAR MODE) 'T)) (CAR MODE))))
('T (WARN X |Non-standard type info| 3 5) (SETQ MODE () )))
(AND (COND ((EQ (SETQ TEM (TYPEP (CADDR X))) 'SYMBOL)
(MEMQ (CADDR X) '(T NIL)))
((EQ TEM 'LIST)
(MEMQ (CAADDR X) '(QUOTE FUNCTION *FUNCTION)))
(T))
(PDERR X |The function pointer cant be right|))
((LAMBDA (EFFS ARITHP KTYPE PNOB)
(COND ((EQ (CAR X) 'LSUBRCALL)
(SETQ X (P1FAKE (CONS (CAR X) (CDDR X))))
(RPLACD (SETQ TEM (CADDDR (CDDAR X)))
(CONS MODE (CDR TEM))))
('T (AND (> (LENGTH (CDDDR X)) 5)
(PDERR X |Too many args for SUBRCALL or ARRAYCALL|))
(SETQ ARITHP 'T Z (P1 (CADDR X)))
(AND (CDR Z) (PDERR X |Numeric function-ptr?|))
(AND (EQ (CAR X) 'ARRAYCALL) (SETQ KTYPE 'FIXNUM))
(SETQ ARITHP () )
(SETQ Z (CONS (CAR Z) (MAPCAR 'P1 (CDDDR X))))
(SETQ X (COND ((EQ (CAR X) 'ARRAYCALL)
(CONS (CAR X) (CONS MODE Z)))
((RPLACA Z (CONS COMP
(CONS MODE (CAR Z))))))))))
() () () 'T)
(GO P1XIT))
((EQ (CAR X) 'ARRAY)
(SETQ X (CONS '*ARRAY
(CONS (LIST 'QUOTE (CADR X))
(CONS (LIST 'QUOTE (CADDR X)) (CDDDR X)))))
(GO B-LSUBR))
((MEMQ (CAR X) '(STATUS SSTATUS))
(SETQ X (CONS (CONS MAKUNBOUND (CONS 'FSUBR (CAR X)))
(P1STATUS X)))
(GO P1XIT))
((MEMQ (CAR X) '(ERRSET *CATCH CATCH-BARRIER CATCHALL
UNWIND-PROTECT CATCH PASS-THRU))
#(LET ((P1VARS LOCVARS) (P1CNT CNT))
(SETQ Z
(P1FAKE
(CASEQ (CAR X)
(ERRSET (LIST 'ERRSET
(LIST 'NCONS (CADR X))
(COND ((NULL (CDDR X)))
((CADDR X)))))
((*CATCH CATCH-BARRIER) X)
(CATCHALL (CONS '%CATCHALL
(CONS (CONS 'FUNCALL
(CONS (CADR X)
CAAGL))
(CDDR X))))
(UNWIND-PROTECT (CONS '%PASS-THRU
(CONS (CONS 'PROGN
(CDDR X))
(LIST (CADR X)))))
(PASS-THRU (CONS '%PASS-THRU
(CONS (LIST 'FUNCALL (CADR X))
(CDDR X))))
(CATCH (LIST '*CATCH
(LIST 'QUOTE (CADDR X))
(CADR X))) )))
(P1BUG P1CNT P1VARS))
(RETURN Z))
((EQ (CAR X) 'THROW)
(SETQ X (LIST '*THROW
(LIST 'QUOTE (CADDR X))
(P1VN (CADR X))))
(GO P1XIT))
((SETQ TEM (ASSQ (CAR X) '((FUNCTION . QUOTE) (*FUNCTION . *FUNCTION))))
(COND ((OR (NULL (CDR X)) (CDDR X)) (GO WNA)))
(SETQ X (LIST (CDR TEM) (P1GFY (CADR X) 'EXPR)))
(GO P1XIT))
((EQ (CAR X) 'SIGNP) (SETQ X (P1SIGNP X)) (GO P1XIT))
((EQ (CAR X) 'BREAK)
(AND (OR (NULL (CDR X)) (CDDDR X)) (GO WNA))
(SETQ X (LIST '*BREAK
(COND ((CDDR X) (CADDR X))
('(QUOTE T)))
(LIST 'QUOTE (CADR X))))
(P1SQV PROGN)
(GO B-SUBR))
((EQ (CAR X) 'PROGV)
(AND (NULL (CDDDR X)) (GO WNA))
(RETURN (P1PROGN (CDR X) 'PROGV)))
((EQ (CAR X) 'ERR)
(SETQ X (COND ((NULL (CDR X)) '(ERR '() ) )
((OR (NULL (CDDR X))
(AND (CADDR X) (NOT (QNILP (CADDR X)))))
(LIST 'ERR (P1VN (CADR X))))
(X)))
(GO P1XIT))
((MEMQ (CAR X) '(DECLARE EVAL-WHEN))
(PDERR X |Local declaration at wrong place|)
(RETURN X))
('T (AND (NOT (GET X 'ACS)) (P1SQV PROGN))
(RETURN (P1MODESET X)))))
((EQ FTYP 'LSUBR)
(COND ((MEMQ (CAR X) '(LIST LIST*))
(SETQ X (COND ((NULL (CDR X)) (GO P1NIL))
((P1ITERLIST (CDR X)
(EQ (CAR X) 'LIST*)))))
(COND (ARITHP (RETURN (NCONS (P1VN X))))
('T (GO B-SUBR)))))
(AND (P1ACK (CAR X) 'LSUBR () (CDR X)) (GO WNA))
(AND (EQ (GET (CAR X) 'NOTNUMP) 'EFFS) (P1SQV NULFU))
(COND ((EQ (CAR X) 'PROG2) (RETURN (P1PROG2 (CDR X))))
((EQ (CAR X) 'PROGN)
(RETURN (P1PROGN (COND ((CDR X)) ( '( () ) )) PROGN)))
((COND ((AND (NULL (CDR X))
(SETQ Z (ASSQ (CAR X) '((READ . *READ)
(READCH . *READCH)
(TYI . *TYI)
(TERPRI . *TERPRI))))))
((AND (CDR X) (NULL (CDDR X))
(SETQ Z (ASSQ (CAR X) '((PRINT . *PRINT)
(PRIN1 . *PRIN1)
(PRINC . *PRINC)
(TYO . *TYO))))))
((AND (CDR X) (CDDR X) (NULL (CDDDR X))
(OR (SETQ Z (ASSQ (CAR X) '((APPEND . *APPEND)
(NCONC . *NCONC)
(DELETE . *DELETE)
(DELQ . *DELQ))))
(AND (NOT CLOSED)
(SETQ Z (ASSQ (CAR X) '((GREATERP . *GREAT)
(LESSP . *LESS)
(PLUS . *PLUS)
(DIFFERENCE . *DIF)
(TIMES . *TIMES)
(QUOTIENT . *QUO)))))))))
;Fall thru for normal CALL processing after this
(SETQ X (CONS (CDR Z) (CDR X))))
((SETQ Z (ASSQ (CAR X) '((MAPCAN (*MAP 0) MAPCON CAR)
(MAPCON (*MAP 1) MAPCON LIST)
(MAPC (*MAP 2) MAP CAR)
(MAP (*MAP 3) MAP LIST)
(MAPCAR (*MAP 4) MAPLIST CAR)
(MAPLIST (*MAP 5) MAPLIST LIST)
(MAPATOMS))))
(RETURN (P1MAP (CDR X) Z)))
((EQ (CAR X) 'FUNCALL)
(COND ((NULL (CDR X)) (GO WNA))
((AND (NOT (ATOM (SETQ Z (CADR X))))
(SETQ Z (P1FUNGET (CADR X))))
(SETQ X (COND ((AND (ATOM (CADR Z))
(OR (GET (CADR Z) '*FEXPR)
(EQ (SYSP (CADR Z)) 'FSUBR)))
(CONS 'APPLY (CDR X)))
('T (CONS (CADR Z) (CDDR X))))))
('T (SETQ X (CONS (CONS COMP (CONS 'FUNCALL (CADR X))) (CDDR X)))))
(GO P1-START))
((AND (EQ (CAR X) 'BOOLE)
(SETQ Z (COND ((ATOM (CADR X)) (CADR X))
((EQ (CAADR X) 'QUOTE) (CADADR X))
((NOT (EQ (SETQ Z (P1MACROGET (CADR X)))
NULFU))
(SETQ X (CONS 'BOOLE (CONS Z (CDDR X))))
(GO P1-START))))
(FIXP Z)
(NOT (< Z 0))
(< Z 1←4)))
;Dont need to P1FAKE explicit BOOLE since will be open coded anyway
((EQ (CAR X) '*ARRAY)
(COND ((AND (NOT (ATOM (CADR X))) (EQ (CAADR X) 'QUOTE))
(AND (COND ((NOT (SYMBOLP (SETQ Z (CADADR X)))))
((AND (GET Z '*ARRAY)
(SETQ Z (GET Z 'NUMFUN)))
(SETQ Y (COND ((MEMQ (CADDR X) '(T NIL)) (CADDR X))
((AND (P1EQQTE (CADDR X))
(MEMQ (CADR (CADDR X))
'(T NIL FIXNUM FLONUM OBARRAY)))
(CADR (CADDR X)))))
(COND ((MEMQ Y '(FIXNUM FLONUM)) (NOT (EQ Y (CADR Z))))
((MEMQ (CADR Z) '(FIXNUM FLONUM))))))
(PDERR X |Contradicts declared type of array|))))
(P1SQV PROGN)
(RETURN (P1FAKE X)))
((AND (EQ (CAR X) 'HUNK) (< (SETQ TEM (LENGTH (CDR X))) 5))
(SETQ Z (CASEQ TEM
(0 (GO P1NIL))
(1 'NCONS)
(2 'CONS)
(3 '%HUNK3)
(4 '%HUNK4)
(T (GO WNA))))
(SETQ X (CONS Z (CDR X)))
(GO B-SUBR))
((AND (EQ (CAR X) 'APPLY)
(NULL (CDDDR X))
(RETURN (PWTNTPTFN (CDR X)))))
((AND (EQ (CAR X) 'EVAL) (NULL (CDDR X)))
(P1SQV PROGN)
(SETQ Z (LIST (P1VN (CADR X))))
(COND ((AND (NOT (ATOM (CAR Z))) ;hac for
(EQ (CAAR Z) 'CONS) ;(EVAL (CONS 'FSUBR L))
(SETQ X (P1F (CADAR Z) (CADDAR Z)))))
('T (SETQ X (CONS '*EVAL Z))))
(GO P1XIT))
('T (COND ((GET (CAR X) 'ACS) ;Pass on out the
(AND (EQ (GET (CAR X) 'NOTNUMP) 'EFFS) ; severity info, if there
(P1SQV NULFU))) ; really are side effects
('T (P1SQV PROGN)))
(RETURN (P1FAKE X)))))
((EQ FTYP 'SUBR)
(AND (P1ACK (CAR X) 'SUBR () (CDR X)) (GO WNA))
(AND (EQ (CAR X) 'NOT) (SETQ X (CONS 'NULL (CDR X))))
(SETQ Y 'T)
(COND ((EQ (CAR X) 'NULL)
(AND (NUMTYPEP (CADR X) () )
(WARN X |Attempt to apply NULL to a numeric quantity| 3 5))
(SETQ X ((LAMBDA (EFFS ARITHP KTYPE)
(COND ((AND (P1BOOL1ABLE (CADR X))
(OR EFFS (NOT (EQ (CAADR X) 'MEMQ))))
(COND (EFFS (LIST 'NULL (P1 (CADR X))))
('T (P1COND 'COND (LIST (LIST X 'T))))))
('T (SETQ EFFS () ) (LIST 'NULL (P1 (CADR X))))))
EFFS () () ))
(GO P1XIT))
((EQ (CAR X) 'RETURN) (RETURN (P1RETURN X)))
((NOT (GET (CAR X) 'ACS))
(COND ((EQ (CAR X) 'BOUNDP)
(SETQ X (LIST 'NOT
(CONS 'EQ (CONS (LIST 'SYMEVAL (CADR X))
QSM))))
(GO B-?))
((MEMQ (CAR X) '(ROT LSH FSC))
(SETQ MODE (COND ((EQ (CAR X) 'FSC) 'FLONUM)
('FIXNUM)))
((LAMBDA (KTYPE ARITHP EFFS)
(SETQ X (LIST (CAR X)
(P1 (CADR X))
(PROG2 (SETQ KTYPE 'FIXNUM)
(P1 (CADDR X))))))
(COND ((CDR (NUMTYP (CADR X) 'T)))
(MODE))
()
() )
(AND (NOT (ATOM (SETQ TEM (CADDR X))))
(EQ (CAR TEM) 'QUOTE)
(NOT (NUMBERP (CADR TEM)))
(PDERR X |Invalid 2nd arg - must be numeric|))
(GO P1XIT))
((GET (CAR X) 'P1BOOL1ABLE)
(AND (MEMQ (CAR X) '(NUMBERP FIXP FLOATP))
(SETQ TEM (NUMTYPEP (CADR X) () ))
(COND ((EQ (CAR X) 'FIXP) (EQ (CDR TEM) 'FIXNUM))
((EQ (CAR X) 'FLOATP) (EQ (CDR TEM) 'FLONUM))
((EQ (CAR X) 'NUMBERP) (CDR TEM)))
(PROG2 (WARN X |Numeric predicate applied
to numeric type datum is a constant| 4 5)
(SETQ X (LIST 'PROG2 (CADR X) TEM))
(GO B-LSUBR))))
((EQ (CAR X) 'SET)
(AND (NOT (ATOM (CADR X)))
(EQ (CAADR X) 'QUOTE)
(ATOM (CADADR X))
(RETURN (P1 (APPEND (LIST 'SETQ (CADADR X)) (CDDR X))))))
((MEMQ (CAR X) '(CXR RPLACX))
(AND (COND ((ATOM (SETQ TEM (CADR X))))
((QNP TEM) (SETQ TEM (CADR TEM)) 'T))
(FIXP TEM)
(COND ((= TEM 0) (SETQ TEM '(CDR . RPLACD)) 'T)
((= TEM 1) (SETQ TEM '(CAR . RPLACA)) 'T))
(SETQ X (CONS (COND ((EQ (CAR X) 'CXR) (CAR TEM))
((CDR TEM)))
(CDDR X)))
(GO B-?)))
((EQ (CAR X) 'SYMEVAL)
(RETURN (P1CARCDR (CONS 'CDDAR (CDR X)))))
('T (P1SQV PROGN))))
((MEMQ (CAR X) '(MEMBER ASSOC SASSOC EQUAL MEMQ))
(RETURN (P1LST X)))
((MEMQ (CAR X) '(NTH NTHCDR))
(SETQ Y (CDR X))
((LAMBDA (EFFS ARITHP KTYPE PNOB)
(SETQ TEM (P1 (CAR Y))
ARITHP (SETQ KTYPE (SETQ PNOB () ))
Y (LIST (CAR TEM) (P1 (CADR Y)))))
() 'T 'FIXNUM 'T)
(SETQ X (COND ((AND (CDR TEM)
(QNP (CAR Y))
(FIXP (SETQ Z (CADAR Y)))
(< Z 6))
(AND (< Z 0)
(SETQ Z 0)
#(PDERR X |Negative count to NTH|))
(SETQ Z #(NCDR '(D D D D D) (- 5 Z)))
(AND (EQ (CAR X) 'NTH) (PUSH 'A Z))
(COND ((NULL Z) (CADR Y))
('T (LIST (CONS CARCDR (REVERSE Z))
(CADR Y)))))
((CONS (CAR X) Y))))
(GO P1XIT))
((EQ (CAR X) 'MAKNUM)
(AND (CDR (SETQ TEM (P1VAP (CADR X) 'T)))
(WARN X |MAKNUM on numeric quantity?| 4 5))
(SETQ X (LIST (CONS MAKUNBOUND '(MAKNUM))
(CAR TEM))
MODE 'FIXNUM)
(GO P1XIT))
((EQ (CAR X) '*FUNCTION)
(SETQ TEM (LIST (P1VN (CADR X))))
(OR (ATOM (CADR X))
(NOT (EQ (CAADR X) 'QUOTE))
(RPLACA TEM (P1GFY (CADAR TEM) 'EXPR)))
(SETQ X (CONS (CAR X) TEM))
(GO P1XIT))
((EQ (GET (CAR X) 'NOTNUMP) 'EFFS) (P1SQV NULFU))))
('T (BARF X |Lost function - P1|)) )
P1-CALL
;This is for the general function-application (CALL)
((LAMBDA (PNOB EFFS ARITHP KTYPE MAPP)
(COND ((AND (NOT (EQ FTYP 'JSP))
(SETQ TEM (GET (CAR X) 'NUMFUN))
(CDDR TEM))
(SETQ MODE (CADR TEM) TEM (CDDR TEM)
Z () ARITHP 'T)
(SETQ Z (MAPCAR
'(LAMBDA (ITEM)
(SETQ MAPP (COND ((ATOM ITEM) () )
((MEMQ (CAR ITEM)
'(MAP MAPC MAPLIST MAPCAR
MAPCAN MAPCON MAPATOMS)))))
(SETQ KTYPE (CAR TEM) TEM (CDR TEM))
(SETQ ITEM (P1 ITEM)) ;TEM IS LIST OF DECLARED ARG TYPES
(COND (Z ITEM) ;Z IS FLAG TO INDICATE MIS-MATCH
((COND ((NULL KTYPE) () )
((CDR ITEM) (NOT (EQ KTYPE (CDR ITEM))))
(MAPP)
((NOTNUMP (CAR ITEM))))
(P1ARG-WRNTYP X)
(SETQ Z 'T ARITHP () )
(CAR ITEM))
((CAR ITEM))))
(CDR X)))
(SETQ X (CONS (CAR X) Z))
(GO P1XIT))
('T (AND (EQ FTYP 'SUBR) (NULL Y) (SETQ PNOB () ))
(SETQ Z (MAPCAR 'P1 (CDR X))))))
'T () () () () )
(RETURN (P1MODESET (CONS (CAR X) Z)))
WNA #(PDERR X |Wrong number of args|)
P1NIL (RETURN (COND (ARITHP '('() . () ) ) ( ''() )))
P1XIT (RETURN (COND (ARITHP (CONS X MODE)) (X))) ))
(DEFUN PWTNTPTFN (X) ;Page Width Too Narrow To Print This Function's Name
((LAMBDA (NARGS FUN VAR FL FORM)
(COND ((COND ((OR (NULL FUN) (NULL (SETQ FUN (CADR FUN)))) ;Find form like
() ) ;(APPLY (FUNCTION
((NOT (ATOM FUN)) ; (LAMBDA (A B) FOO))
(COND ((NOT (EQ (CAR FUN) 'LAMBDA)) () ) ; BAR)
((OR (NOT (ATOM (SETQ FORM (CADR FUN)))) ;LAMBDA list
(NULL FORM))
(SETQ NARGS (LENGTH FORM))
'T)))
((AND (EQ (SYSP FUN) 'SUBR) (SETQ FORM (ARGS FUN)))
(SETQ NARGS (CDR FORM)) ;# of args to function
'T))
(SETQ VAR (CADR X))
(AND (> NARGS 1) ;2 or more LAMBDA vars in
(NOT (ATOM VAR)) ;some complexly-computed list
(NOT (EQ (CAR VAR) 'QUOTE))
(NOT (P1CARCDR-CHASE VAR))
(SETQ VAR (GENSYM) FL 'T))
(SETQ FORM (CONS FUN
(DO ((A VAR (LIST 'CDDDDR A)) (Z))
((NOT (> NARGS 0)) (NREVERSE Z))
(DO ((N (COND ((> NARGS 4) 4) (NARGS)) (1- N))
(FUN '(CAR CADR CADDR CADDDR) (CDR FUN)))
((NOT (> N 0)))
(SETQ NARGS (1- NARGS))
(PUSH (LIST (CAR FUN) A) Z)))))
(AND FL (SETQ FORM (LIST (LIST 'LAMBDA (LIST VAR) FORM)
(CADR X))))
(P1 FORM))
('T (P1SQV PROGN)
(SETQ FORM (MAPCAR 'P1VN X))
(SETQ FORM (COND ((P1F (CAR FORM) (CADR FORM)))
((CONS '*APPLY FORM))))
(COND (ARITHP (NCONS FORM)) (FORM)))))
0 (P1FUNGET (CAR X)) () () () ))
(DEFUN P1ACK (NAME TYPE FL L) ;P1 args check
#(LET ((AARGS (OR (ARGS NAME) (GET NAME 'ARGS))) TEM)
(COND ((NULL AARGS)
(AND FL (PUTPROP NAME FL 'ARGS))
() )
('T (AND (NOT (ATOM L)) (SETQ L (LENGTH L)))
(SETQ TEM (COND ((NULL (CAR AARGS))
(OR (AND TYPE (NOT (EQ TYPE 'SUBR)))
(NOT (= (CDR AARGS) L))))
((OR (AND TYPE (NOT (EQ TYPE 'LSUBR)))
(< L (CAR AARGS))
(> L (CDR AARGS)))
'T)))
(AND (AND FL TEM)
#(WARN NAME |Has been previously used with wrong number of arguments|))
TEM ))))
(DEFUN P1ANDOR (X ORP)
(PROG (Z)
(COND ((NULL (CDR X)) (RETURN (P1 (NOT ORP))))
((NULL (CDDR X)) (RETURN (P1 (CADR X))))
(EFFS (RETURN (P1COND (CAR X) (CDR X)))))
(SETQ Z (COND (ORP (MAPCAR 'NCONS (CDR X)))
('T (SETQ Z (L2F (CDR X))) ;Convert (AND A B C)
(LIST (LIST (CONS 'AND (CDR Z)) (CAR Z)))))) ; into (COND ((AND B) C))
(RETURN (P1COND 'COND Z))))
(DEFUN P1ARG-WRNTYP (X)
#(PDERR (LIST X 'NOT-OF-TYPE KTYPE)
|First item in list is an argument somewhere, but is of the wrong type|))
(DEFUN P1ARITH (XPR ARITHFUNP NUMBERP)
(P1SQE (PROG (TYP TEMP TEM FUN SAVXPR KNOW-ALL-TYPES P1LSQ LMBP CONDP P1LL PNOB)
(SETQ FUN (CAR XPR) LMBP T SAVXPR XPR)
(AND NUMBERP (MEMQ FUN '(EQ EQUAL)) (GO A0))
(AND NUMBERP
(SETQ TEM (ASSQ FUN '((*PLUS . PLUS) (*TIMES . TIMES)
(*DIF . DIFFERENCE) (*QUO . QUOTIENT)
(*LESS . LESSP) (*GREAT . GREATERP))))
(SETQ FUN (CDR TEM)))
(AND (NULL (CDDR XPR))
(SETQ TEMP (COND ((OR (AND NUMBERP (MEMQ FUN '(PLUS DIFFERENCE)))
(AND ARITHFUNP (MEMQ FUN '(- -$))))
'('0 . '0.0))
((OR (AND NUMBERP (MEMQ FUN '(TIMES QUOTIENT)))
(AND ARITHFUNP (MEMQ FUN '(// //$))))
'('1 . '1.0))))
(COND ((NULL (CDR XPR))
(SETQ XPR (P1 (COND ((MEMQ FUN '(//$ /-$)) (CDR TEMP))
((CAR TEMP)))))
(RETURN P1LSQ))
((NULL (CDDR XPR))
(COND ((MEMQ FUN '(//$ -$))
(SETQ XPR (CONS FUN (CONS (CDR TEMP) (CDR XPR)))))
((MEMQ FUN '(// -))
(SETQ XPR (CONS FUN (CONS (CAR TEMP) (CDR XPR)))))
('T (SETQ XPR (P1 (CADR XPR))) (RETURN P1LSQ))))))
(COND ((SETQ TEMP (COND (ARITHFUNP
(AND (NULL (CADR ARITHFUNP)) (GO A0))
ARITHFUNP) ;type is pre-determined
((AND NUMBERP CLOSED) () ) ;so processing is easy
((OR FLOSW FIXSW)
(CONS FUN (COND (FIXSW '(FIXNUM))
(FLOSW '(FLONUM)))))))
(SETQ XPR ((LAMBDA (ARITHP EFFS KTYPE) (MAPCAR 'P1 (CDR XPR)))
() () (SETQ TYP (CADR TEMP))))
(AND (SETQ TEM (P1AEVAL FUN XPR SAVXPR))
(PROG2 (SETQ XPR TEM) (GO XITF)))
(SETQ FUN (CAR (SETQ XPR (APPEND TEMP XPR)))
TYP (CADR (COND (ARITHFUNP) (TEMP)))
KNOW-ALL-TYPES 'T)
(AND (EQ FUN 'DIFFERENCE)
(Q0P+0P (CAR (SETQ TEMP (CDDR XPR))))
(NULL (CDDR TEMP))
(SETQ XPR (CONS 'MINUS (CONS TYP (CDR TEMP)))))
(GO XITF)))
(AND (NULL (CDDDR XPR)) ;rational op, merely
(EQ NUMBERP 'T) ;to cause FLOATing,
(COND ((COND ((EQ FUN 'TIMES) ;e.g., (PLUS X 0.0)
(AND (SETQ TEM (Q1P+1P-1P (CADR XPR)))
(= TEM 1.0)))
((EQ FUN 'PLUS)
(AND (FLOATP (CADR XPR)) (ZEROP (CADR XPR)))))
(SETQ FUN (CADDR XPR))
'T)
((COND ((MEMQ FUN '(TIMES QUOTIENT))
(AND (FLOATP (CADDR XPR)) (= (CADDR XPR) 1.0)))
((MEMQ FUN '(PLUS DIFFERENCE))
(AND (FLOATP (CADDR XPR)) (ZEROP (CADDR XPR)))))
(SETQ FUN (CADR XPR))
'T))
(PROG2 (RPLACD XPR (LIST FUN))
(RPLACA XPR (SETQ FUN 'FLOAT))))
(AND (GET FUN 'LSUBR) (SETQ PNOB 'T))
A0 ((LAMBDA (ARITHP EFFS KTYPE)
(COND ((AND ARITHFUNP (NULL (CADR ARITHFUNP))) ;Seek special action on =, >, <
(SETQ KTYPE (CDR (NUMTYP (CADR XPR) 'T))
TYP (CDR (NUMTYP (CADDR XPR) 'T)))
(COND ((AND (NULL KTYPE) (NULL TYP)) ;Sigh! No info
((LAMBDA (P1CNT LL LLL ARG1 ARG2 T1 T2) ; from numtypep!
(SETQ ARG1 (P1 (CADR XPR)) T1 (CDR ARG1))
(COND (T1 (SETQ KTYPE T1 ARG2 (P1 (CADDR XPR))))
('T (SETQ ARG2 (P1 (CADDR XPR)) T2 (CDR ARG2))
(SETQ KTYPE (COND (T2)
(FLOSW 'FLONUM)
(FIXSW 'FIXNUM)
('FIXNUM)))
(SETQ CNT P1CNT LOCVARS LL)
(MAPC 'RPLACD LOCVARS LLL)
(SETQ ARG1 (P1 (CADR XPR))
ARG2 (P1 (CADDR XPR)))))
(SETQ TYP KTYPE
XPR (LIST (CAR ARG1) (CAR ARG2))))
CNT LOCVARS (MAPCAR 'CDR LOCVARS) () () () () )
(GO A))
((AND TYP KTYPE (EQ TYP KTYPE))
(AND (SETQ TEM (P1AEVAL FUN (CDR XPR) SAVXPR))
(PROG2 (SETQ XPR TEM) (GO XITF))))
('T (SETQ KTYPE (COND ((NULL KTYPE) TYP) ;KTYPE is set to ()
((NULL TYP) KTYPE) ; only if a conflict is found
((EQ KTYPE TYP) KTYPE))))))
((AND (EQ NUMBERP 'NOTYPE) (MEMQ FUN '(PLUSP MINUSP ZEROP)))
(SETQ KTYPE (OR (CDR (NUMTYP (CADR XPR) 'T)) 'FIXNUM))))
(SETQ TYP () )
(SETQ XPR (MAPCAR
'(LAMBDA (X)
(SETQ X (P1 X))
(PUSH (OR (CDR X) KTYPE) TYP)
(CAR X))
(CDR XPR))))
'T () () )
(COND ((MEMQ (SETQ TYP (SAMETYPES TYP)) '(() FIXNUM FLONUM)))
((SETQ TYP (NREVERSE TYP))))
A (SETQ XPR (CONS FUN (CONS TYP XPR)))
(COND (ARITHFUNP ;Catches =, <, >
(AND (CADR ARITHFUNP)
(BARF SAVXPR |ARITHP function came too far - P1ARITH|))
(AND (NOT (MEMQ TYP '(FIXNUM FLONUM)))
#(PDERR SAVXPR |Mixed modes|))
(RPLACA XPR (CAR ARITHFUNP))
(RPLACA (CDR XPR) TYP)
(SETQ TYP () ) ;Resultant is of NOTYPE
(GO XITF))
((AND (MEMQ TYP '(FIXNUM FLONUM))
(MEMQ FUN '(IFIX FIX FLOAT)))
(AND (COND ((EQ TYP 'FIXNUM) (MEMQ FUN '(FIX IFIX))) ;Catches superfluous
((EQ TYP 'FLONUM) (EQ FUN 'FLOAT))) ;FIX or FLOAT
(SETQ XPR (CADDR XPR))
(GO XITF))
(AND (SETQ TEM (P1AEVAL FUN (CDDR XPR) SAVXPR))
(PROG2 (SETQ XPR TEM) (GO XITF)))))
(SETQ KNOW-ALL-TYPES #(KNOW-ALL-TYPES TYP))
A-EQ
(COND ((EQ FUN 'EQUAL)
(COND ((COND (KNOW-ALL-TYPES (NOT (ATOM TYP)))
((NULL TYP) () )
((NOTNUMP (COND ((CADDR TYP) (CADDDR XPR))
('T (CADDR XPR))))
(RPLACA (CDR XPR) () )
'T))
(WARN SAVXPR |This EQUAL test will never come up true| 4 5))
((AND (NOT KNOW-ALL-TYPES) TYP)
(RPLACA (CDR XPR) () ))
((OR (P1EQQTE (CADDR XPR)) (P1EQQTE (CADDDR XPR)))
(RPLACA XPR 'EQ)
(RPLACA (CDR XPR) (SETQ TYP () ))))
(GO XIT))
((EQ FUN 'EQ)
(COND (TYP (WARN SAVXPR |EQ of a number - EQUAL assumed| 4 5)
(RPLACA XPR (SETQ FUN 'EQUAL))
(GO A-EQ)))
(GO XIT))
((COND ((EQ FUN 'REMAINDER)
(COND ((EQ TYP 'FIXNUM) () )
('T (SETQ KNOW-ALL-TYPES () TYP () )
(RPLACA (CDR XPR) () )
(NOT MUZZLED))))
((AND (NOT KNOW-ALL-TYPES) (NOT MUZZLED) (NOT CLOSED)
(NOT (MEMQ FUN '(FLOAT IFIX))))))
#(WARN SAVXPR |Closed compilation forced| 4 5)))
(AND (NOT KNOW-ALL-TYPES) ;Convert (PLUS A B)
(CDDDR XPR) ;into (*PLUS A B)
(NULL (CDDDDR XPR)) ;IF NOT OPEN-CODED
(SETQ TEMP (ASSOCR (CAR XPR) '((*PLUS . PLUS) (*TIMES . TIMES)
(*DIF . DIFFERENCE) (*QUO . QUOTIENT)
(*LESS . LESSP) (*GREAT . GREATERP))))
(SETQ XPR (CONS (CAAR TEMP) (CDR XPR))))
(COND ((AND (NOT KNOW-ALL-TYPES) (GET (CAR XPR) 'LSUBR))
(SETQ XPR (P1GLM1 ()
XPR
0
(COND ((MEMQ 'FLONUM TYP) 'FLONUM) ;CONTAGIOUS FLOATING
(KTYPE))
() ))
(SETQ CNT (1+ CNT))
(SETQ TYP (AND ARITHP (PROG2 () (CDR XPR) (SETQ XPR (CAR XPR)))))
(SETQ XPR (LIST XPR))
(GO XITF)))
(COND ((EQ FUN 'FLOAT)
(SETQ TYP 'FLONUM)
(GO XITF))
((MEMQ FUN '(FIX IFIX))
(SETQ TYP (COND ((EQ KTYPE 'FLONUM) (P1ARG-WRNTYP SAVXPR) () )
((OR (EQ KTYPE 'FIXNUM) FIXSW)
(RPLACA XPR (SETQ FUN 'IFIX))
'FIXNUM)
((EQ FUN 'IFIX) 'FIXNUM)))
(GO XITF)))
(AND KNOW-ALL-TYPES
(SETQ TEM (P1AEVAL FUN (CDDR XPR) SAVXPR))
(PROG2 (SETQ XPR TEM) (GO XITF)))
(AND KNOW-ALL-TYPES
(MEMQ TYP '(FIXNUM FLONUM))
(CDDDR XPR)
(NULL (CDDDDR XPR))
(COND ((AND (EQ FUN 'DIFFERENCE)
(Q0P+0P (SETQ TEM (CADDR XPR))))
(SETQ TEMP 'MINUS)
'T)
((PROG2 (SETQ TEM (CDR XPR)
TEMP (COND ((MEMQ FUN '(PLUS DIFFERENCE))
(CADDR TEM))
((EQ FUN 'PLUS)
(CAR (SETQ TEM (CDR TEM))))))
(AND TEMP (Q1P+1P-1P TEMP)))
(SETQ TEMP (COND (#(EQUIV (PLUSP TEMP) (EQ FUN 'PLUS))
'ADD1)
('SUB1))
TEM (CADR TEM))
'T))
(PROG2 (SETQ XPR (LIST TEMP TYP TEM)) (GO XITF)))
XIT (SETQ TYP (COND ((EQ FUN 'HAULONG) 'FIXNUM)
((EQ NUMBERP 'NOTYPE)
(AND (NULL EFFS) KTYPE (P1ARG-WRNTYP SAVXPR))
())
(CLOSED (RPLACA (CDR XPR) () ) () ) ;All ARITHP types taken earlier
((ATOM TYP) (OR TYP KTYPE)) ;Only NUMBERP types come here
((MEMQ 'FLONUM TYP) 'FLONUM)
((AND (MEMQ 'FIXNUM TYP)
(OR (EQ FUN 'REMAINDER)
(AND (EQ FUN 'GCD) (CAR TYP) (CADR TYP))))
'FIXNUM)
(KTYPE)))
XITF (AND ARITHP (SETQ XPR (CONS XPR TYP)))
(RETURN P1LSQ)))
XPR)
(DEFUN P1AEVAL (FUN ARGL SAVXPR) ;Called only by "P1ARITH"
((LAMBDA (TEM)
(AND (DO ((Z ARGL (CDR Z))) ((NULL Z) 'T)
(AND (OR (ATOM (CAR Z)) (NOT (EQ (CAAR Z) 'QUOTE)))
(RETURN () )))
(COND ((ERRSET (SETQ TEM (EVAL (CONS FUN ARGL))) () )
(LIST 'QUOTE TEM))
('T (PDERR SAVXPR |Illegal arithmetic construction|)
''() ))))
() ))
(DEFUN P1BINDARG (SPFL VAR OARG KTYPE)
((LAMBDA (TYP ARG ARITHP PNOB EFFS)
(SETQ TYP KTYPE)
(COND ((AND SPFL (NULL TYP)) (SETQ ARITHP () ) (P1 OARG)) ;SPECIAL, non-numeric var
(TYP
(SETQ ARG (P1 OARG))
(COND ((COND ((CDR ARG) (NOT (EQ (CDR ARG) TYP)))
((NOTNUMP (CAR ARG))))
(PDERR (LIST VAR OARG)
|Binding number variable to quantity of wrong type|)
(COND ((EQ TYP 'FIXNUM) ''1) (''1.0)))
((CAR ARG))))
((COND ((NULL (SETQ ARG (NUMTYP OARG () ))) () ) ;Local-list-type-var being
((EQ (SETQ TYP (TYPEP (CAR ARG))) 'SYMBOL) ; bound to something that
(NOT (SPECIALP (CAR ARG)))) ; just might be a PDLNUM
((EQ TYP 'LIST) (NOT (EQ (CAAR ARG) 'COND)))
((NOT (MEMQ TYP '(FIXNUM FLONUM)))))
(SETQ ARG (P1 OARG))
(NLNVEX VAR
(COND ((CDR ARG)
(SETQ CNT (+ CNT 2))
(CADR (SETQ ARG (LIST 'SETQ (NLNVCR VAR (CDR ARG)) (CAR ARG)))))
('T (P2UNSAFEP (SETQ ARG (CAR ARG))))))
ARG)
('T (SETQ PNOB VAR ARG (P1 OARG) OARG (P2UNSAFEP (CAR ARG)))
(AND OARG
(OR (NOT (ATOM OARG)) (NUMERVARP OARG)) ;See note below
(NLNVEX VAR OARG))
(CAR ARG))))
() () 'T () () ))
;;; Note: We dont want a var X to get unsafe just because it occurs somewhere (SETQ X Y)
;;; and Y is unsafe [where both X and Y are LLTVS
(DEFUN P1BOOL1ABLE (X)
(COND ((OR (ATOM X) (NOT (ATOM (CAR X)))) () )
((EQ (CAR X) 'PROG2) (AND (NULL (CDDDR X)) (P1BOOL1ABLE (CADDR X))))
(((LAMBDA (PROP)
(COND ((NULL PROP) () )
((EQ PROP 'NUMBERP)
(COND ((AND P2P (MEMQ (CADR X) '(FIXNUM FLONUM))) X)
(CLOSED () )
((NULL P2P) X)))
('T X))) ;PROP must be either T or A fixnum here
(GET (CAR X) 'P1BOOL1ABLE)))))
;;; On P1, when it is the "numberp" case such as "PLUSP, or "GREATERP",
;;; this may answer yes falsely, since we dont know whether or not
;;; all the arithmetics are of the same type
(DEFUN P1BASICBOOL1ABLE (X) (AND (SETQ X (P1BOOL1ABLE X)) (NOT (MEMQ (CAR X) '(AND OR MEMQ COND)))))
(DEFUN P1BUG (P1CNT P1VARS)
(SETQ CNT (ADD1 CNT))
(DO X P1VARS (CDR X) (NULL X)
(COND ((> (CDAR X) P1CNT) (RPLACD (CAR X) CNT))))
(SETQ CNT (ADD1 CNT)))
(DEFUN P1CARCDR (X)
(PROG (Y TEM)
(COND ((OR (NULL (CDR X)) (CDDR X))
#(PDERR X |Wrong number of arguments|)
(SETQ Y ''() ) (GO XIT)))
(SETQ Y (P1VAP (CADR X) () ))
(AND (CDR Y)
(PDERR X |Attempt to take CAR or CDR of a numeric quantity|))
(SETQ Y (CAR Y))
(COND ((AND (SETQ TEM (NOT (ATOM Y))) ;(CAR (CDR X))
(NOT (ATOM (CAR Y))) ;GOES FIRST INTO
(EQ (CAAR Y) CARCDR)) ;(CAR ((CARCDR D) X)) THEN TO
(NCONC (CAR Y) (P1CCEXPLODE (CAR X)))) ;((CARCDR D A) X)
((AND TEM (EQ (CAR X) 'CDR) (EQ (CAR Y) 'RPLACD))
(SETQ Y (CONS (CONS MAKUNBOUND '(RPLACD)) (CDR Y))))
('T (SETQ Y (LIST (CONS CARCDR (P1CCEXPLODE (CAR X))) Y))))
XIT (RETURN (COND (ARITHP (NCONS Y)) (Y)))))
(DEFUN P1CARCDR-CHASE (X)
(COND ((ATOM X) X)
((NULL (CDR X)) () )
((CDDR X) () )
((AND (SYMBOLP (CAR X)) (GET (CAR X) 'CARCDR))
(P1CARCDR-CHASE (CADR X)))))
(DEFUN P1CCEXPLODE (FUN)
(DO ((FUN (GET FUN 'CARCDR) (GET FUN 'CARCDR)) (L))
((NULL FUN) L)
(PUSH (CAR FUN) L)
(SETQ FUN (CADR FUN))))
(DEFUN P1ITERLIST (L FL)
(COND ((NULL (CDR L)) (COND (FL (CAR L)) ((LIST 'NCONS (CAR L)))))
('T (LIST 'CONS (CAR L) (P1ITERLIST (CDR L) FL)))))
;;; The CONDTYPE var has a rigid format - see P1TYPE-ADD
(DEFUN P1COND (FUN X)
(PROG (P1VARS P1CNT BODY CONDTYPE CONDUNSF CONDPNOB
CONDP P1CSQ LMBP P1LSQ P1CCX ARITHP)
(SETQ P1VARS LOCVARS P1CNT CNT CONDP 'T P1CCX 0)
(SETQ BODY (XCONS (MAPCAR '(LAMBDA (X) (COND ((EQ FUN 'COND) (P1CDC X))
((P1AOC X))))
X)
(COND ((NOT (EQ FUN 'COND)) () )
((NULL (CDR CONDTYPE)) KTYPE)
((NULL KTYPE)
(COND ((CDDR CONDTYPE) () )
((AND (CAR CONDTYPE)
(EQ (CAR CONDTYPE) (CADR CONDTYPE)))
(CAR CONDTYPE))
(CONDTYPE)))
((OR (CDDR CONDTYPE)
(NOT (EQ KTYPE (CADR CONDTYPE)))
(AND (CAR CONDTYPE)
(NOT (EQ KTYPE (CAR CONDTYPE)))))
(PDERR (CONS FUN X) |COND has clause of wrong numeric type|)
() )
(KTYPE))))
(SETQ X (CONS FUN (CONS P1CCX (CONS P1CSQ (CONS CONDUNSF BODY)))))
(P1BUG P1CNT P1VARS))
(P1SQE (CADDR X))
(COND (ARITHP (OR (ATOM (SETQ FUN (CADDDR (CDR X)))) (SETQ FUN () )) (CONS X FUN))
(X)))
(DEFUN P1AOC (J)
;;; Compile a piece in an AND-OR clause, or the first part of a COND clause
(COND ((P1BOOL1ABLE J) (P1E J)) ;If MEMQ is not BOOL1ABLE, then need special check
((P1VN J)))) ; for (MEMQ X '(A B)) to go into (OR (EQ X A) (EQ X B))
(DEFUN P1CDC (J) ;P1s COND clause analyzer
(COND ((NOT (EQ (TYPEP J) 'LIST))
(PDERR J |Random COND clause|)
'( '() ) )
((COND ((NULL (CDR J)))
((CDDR J) () ) ;Singleton COND clause, or
((AND (OR (EQ (CADR J) 'T) ; like ((EQ X Y) T) or
(AND (NOT (ATOM (CADR J))) ; ((NULL BARF) (QUOTE T))
(EQ (CAADR J) 'QUOTE)
(EQ (CADADR J) 'T))) ;All converted to singleton
(P1BASICBOOL1ABLE (CAR J))) ; like (foobar)
(SETQ J (LIST (CAR J)))
'T))
(COND ((ATOM (CAR J)) (P1CJ J))
((MEMQ (CAAR J) '(GO RETURN)) (P1CDC (CONS 'T J)))
(EFFS (LIST (P1AOC (CAR J))))
((OR (P1BASICBOOL1ABLE (CAR J))
(AND (EQ (CAAR J) 'OR)
(CDAR J)
(CDDAR J)
(P1BASICBOOL1ABLE (CADDAR J))
(P1BASICBOOL1ABLE (CADR J))))
(CONS (P1E (CAR J)) (P1CJ '(T))))
('T (P1CJ J))))
((AND (NOT EFFS)
(NULL (CDDR J)) ;((NULL FOO) () )
(OR (EQ (CAAR J) 'NULL) (EQ (CAAR J) 'NOT))
(OR (NULL (CADR J)) (QNILP (CAAR J)))
(OR (NOT (P1BOOL1ABLE (CADAR J))) (EQ (CAADAR J) 'MEMQ)))
(NREVERSE (CONS NULFU (P1CJ (CDAR J)))))
((CONS (P1AOC (CAR J))
(COND ((NULL (CDDR J)) (P1CJ (CDR J)))
('T (SETQ J (L2F (CDR J)))
(NRECONC (DO ((LL (CDR J) (CDR LL)) (Z) (ARITHP) (EFFS))
((NULL LL) Z )
(PUSH (P1 (CAR LL)) Z))
(P1CJ J))))))))
(DEFUN P1CJ (J)
((LAMBDA (ARITHP MODE FL)
(SETQ J (P1 (CAR J)))
(COND (ARITHP
(SETQ MODE (CDR J) J (CAR J))
(SETQ P1CCX (PLUS P1CCX (P1TRESS J)))
(COND ((NOT (SETQ FL (P2UNSAFEP J))))
((NOT (ATOM FL)) (SETQ CONDUNSF (LADD FL CONDUNSF) FL 'T))
((NULL (VARMODE FL)) (PUSH FL CONDUNSF) (SETQ FL () ))
((SETQ FL GOFOO))) ;Local numeric type vars are always unsafe
; so dont need to put explicitly on UNSFLST
(SETQ CONDTYPE (P1TYPE-ADD CONDTYPE MODE))))
(COND ((AND PNOB ;If a PDL number is in order
MODE ; and val is numeric,
(NOT (EQ FL GOFOO)) ; but not fixnumvar
(OR FL (P1CJ-NUMVALP J))) ; then might need NLNVTHTBP
(AND (NULL CONDPNOB) (SETQ CONDPNOB (CONS () () )))
(SETQ CNT (+ CNT 2) FL () )
(SETQ MODE (COND ((EQ MODE 'FIXNUM)
(AND (NULL (CAR CONDPNOB))
(RPLACA CONDPNOB (SETQ FL (NLNVFINDCR MODE 'COND))))
(CAR CONDPNOB))
((EQ MODE 'FLONUM)
(AND (NULL (CDR CONDPNOB))
(RPLACD CONDPNOB (SETQ FL (NLNVFINDCR MODE 'COND))))
(CDR CONDPNOB))))
;MODE now has name of NLNVTHTBP, either FIXNUM or FLONUM, for the wings of the COND
;FL is non-null if name is newly created
(AND FL (NOT (EQ CONDUNSF 'T)) (PUSH MODE CONDUNSF))
(SETQ J (CONS 'SETQ (LIST MODE J)))))
(NCONS J))
(NOT EFFS) () () ))
;;; Basically, a PHASE2 type analyzer, except that quoted numbers
;;; and variables are ignored. Called only by P1CJ.
(DEFUN P1CJ-NUMVALP (FORM)
(COND ((ATOM FORM) () )
((NOT (ATOM (CAR FORM)))
(COND ((EQ (CAAR FORM) 'LAMBDA) (P1CJ-NUMVALP (CADDDR (CDDAR FORM))))
((EQ (CAAR FORM) COMP)
(AND (MEMQ (CADAR FORM) '(FIXNUM FLONUM)) (CADAR FORM)))))
((MEMQ (CAR FORM) '(SETQ QUOTE)) () )
((EQ (CAR FORM) 'PROG2) (P1CJ-NUMVALP (CADDR FORM)))
((OR (EQ (CAR FORM) 'PROGN) (EQ (CAR FORM) PROGN) (EQ (CAR FORM) 'PROGV))
(P1CJ-NUMVALP (CAR (LAST (CDR FORM)))))
((AND (SETQ FORM (NUMFUNP FORM () )) (NOT (EQ FORM 'T))) FORM)))
(DEFUN P1CASEQ (X)
(PROG (KEYFORM LFORM EXP TYPE-PRED TEM LL CLAUSES)
(DECLARE (SPECIAL KEYFORM TYPE-PRED))
(SETQ EXP (CDR X))
(POP EXP KEYFORM)
(AND (OR (NULL KEYFORM) (NUMBERP KEYFORM) (ATOM EXP) (ATOM (CAR EXP)))
(RETURN () ))
(COND ((ATOM KEYFORM))
((OR (NOT (P1CARCDR-CHASE KEYFORM)) ;Wrap a LAMBDA around it
(> (FLATC (CAR KEYFORM)) 4) ; if not "simple".
(NOT (ATOM (CADR KEYFORM))))
(SETQ TEM (GENSYM))
(SETQ LFORM (LIST (LIST 'LAMBDA (LIST TEM) NULFU) KEYFORM))
(SETQ KEYFORM TEM)))
(SETQ TYPE-PRED (ASSQ (TYPEP (COND ((ATOM (CAAR EXP)) (CAAR EXP))
('T (CAAAR EXP))))
'((SYMBOL . EQ) (FIXNUM . =) (FLONUM . =))))
(AND (NULL TYPE-PRED) (RETURN () ))
(SETQ LL EXP CLAUSES () )
A (COND (LL (PUSH (CONS (COND ((ATOM (CAR LL)) (RETURN () ))
((ATOM (CAAR LL))
(COND ((EQ (CAAR LL) 'T) ''T)
((P1CASEQ-CLAUSE (CAAR LL)))
('T (RETURN () ))))
('T (SETQ TEM (MAPCAR 'P1CASEQ-CLAUSE
(CAAR LL)))
(AND (MEMQ () TEM) (RETURN () ))
(COND ((NULL (CDR TEM)) (CAR TEM))
((CONS 'OR TEM))) ))
(CDAR LL))
CLAUSES)
(POP LL)
(GO A)))
(SETQ EXP (CONS 'COND (NREVERSE CLAUSES)))
(RETURN (COND (LFORM (RPLACA (CDDAR LFORM) EXP) LFORM)
(EXP))) ))
(DEFUN P1CASEQ-CLAUSE (X)
(DECLARE (SPECIAL TYPE-PRED KEYFORM))
(COND ((NOT (EQ (TYPEP X) (CAR TYPE-PRED))) () )
('T (LIST (CDR TYPE-PRED) KEYFORM (LIST 'QUOTE X)))))
(DEFUN P1DO (XX)
(PROG (INDXL ENDTST ENDVAL TG1 TAG3 PVARS LVARS STEPDVARS LVALS BODY DECL X)
(SETQ X (CDR XX))
(COND ((AND (CAR X) (ATOM (CAR X)))
(SETQ INDXL (LIST (LIST (POP X) (POP X) (POP X)))
ENDTST (POP X)
ENDVAL ()
TG1 (LIST (GENSYM))))
('T (SETQ INDXL (REVERSE (POP X)))
(COND ((SETQ ENDTST (POP X))
(SETQ ENDVAL (COND ((OR (NULL (CDR ENDTST))
(NULL (CADR ENDTST))
(AND (NOT (ATOM (CADR ENDTST)))
(QNILP (CADR ENDTST))))
() )
('T (REVERSE (CDR ENDTST))))
ENDTST (CAR ENDTST)
TG1 (LIST (GENSYM))))
('T (SETQ ENDTST CLPROGN)))))
(MAPC '(LAMBDA (X) (COND ((COND ((ATOM X))
((NULL (CDR X)) (SETQ X (CAR X)) 'T))
(PUSH X PVARS))
('T (PUSH (CAR X) LVARS)
(PUSH (CADR X) LVALS)
(AND (CDDR X) (PUSH X STEPDVARS))
(AND (CDDDR X) (SETQ XX () ))
(SETQ X (CAR X))))
(AND (NOT (SYMBOLP X)) (SETQ XX () )))
INDXL)
(AND (NULL XX) (RETURN () ))
(AND (NOT (ATOM (CAR X)))
(EQ (CAAR X) 'DECLARE)
(POP X DECL))
(SETQ BODY (LIST
(NCONC (LIST 'PROG PVARS)
TG1
(AND (AND TG1 ENDTST)
(OR (ATOM ENDTST) (NOT (QNILP ENDTST)))
(LIST
(LIST
'COND
(CONS ENDTST
(COND ((NULL ENDVAL) '((RETURN () )))
(TAG3 (LIST (LIST 'GO TAG3)))
('T (P1DO-RETURN ENDVAL)))))))
(APPEND X () )
(AND STEPDVARS (LIST (P1DO-STEPPER STEPDVARS)))
(LIST (COND (TG1 (LIST 'GO (CAR TG1)))
((EQ ENDTST CLPROGN) '(RETURN () ))
((DBARF XX |Bad DO format|)) ))
(AND TAG3 (CONS TAG3 (P1DO-RETURN ENDVAL))))))
(AND DECL (SETQ BODY (CONS DECL BODY)))
(RETURN (CONS (CONS 'LAMBDA (CONS LVARS BODY)) LVALS))))
(DEFUN P1DO-RETURN (ENDVAL)
(NREVERSE (CONS (LIST 'RETURN (CAR ENDVAL)) (CDR ENDVAL))))
(DEFUN P1DO-STEPPER (L)
(LIST 'SETQ
(CAAR L)
(COND ((NULL (CDR L)) (CADDAR L))
((LIST 'PROG2 () (CADDAR L) (P1DO-STEPPER (CDR L)))))))
(DEFUN P1EQQTE (Z)
(AND (NOT (ATOM Z))
(EQ (CAR Z) 'QUOTE)
(SYMBOLP (CADR Z))))
(DEFUN P1E (X) ((LAMBDA (EFFS) (P1 X)) 'T))
(DEFUN P1E1 (X)
; Called only from P1PROG
; Tries to factor out a SETQ from a COND - for example,
; (COND ((AND (SETQ X (FOO)) ALPHA) (RETURN () )))
; goes into
; (PROG2 (SETQ X (FOO)) (COND ((AND X ALPHA) (RETURN () ))))
(COND ((OR PRSSL (NOT (MEMQ (CAR X) '(COND AND OR)))) (P1 X))
(((LAMBDA (DATA TEM F)
(AND (SETQ DATA (P1HUNOZ (SETQ TEM (COND (F (CADR X))
((CDR X))))))
(OR (MEMQ (CADR DATA) BVARS)
(ASSQ (CADR DATA) RNL))
(P1 (PROG2 (SETQ TEM (P1HUNOZ TEM))
(LIST 'PROG2
DATA
(CONS (CAR X)
(COND (F (CONS TEM (CDDR X)))
(TEM))))))))
() () (EQ (CAR X) 'COND)))
((P1 X))))
(DEFUN P1HUNOZ (Y) (COND ((OR (ATOM (CAR Y))
(NULL (CDAR Y))
(NOT (ATOM (CAAR Y)))
(ASSQ (CAAR Y) MACROLIST))
(AND DATA Y))
((EQ (CAAR Y) 'SETQ) (COND (DATA (CONS (P1FV (CDAR Y)) (CDR Y)))
('T (CAR Y))))
((GETL (CAAR Y) '(FEXPR FSUBR *FEXPR MACRO)) (AND DATA Y))
(DATA (CONS (CONS (CAAR Y) (P1HUNOZ (CDAR Y))) (CDR Y)))
((P1HUNOZ (CDAR Y)))))
(DEFUN P1F (F L)
; PATCH UP FOR FORMS OF (EVAL (CONS 'FSUBR LIST))
(AND (P1KNOWN F '(FSUBR *FEXPR)) (CONS (CONS MAKUNBOUND (CONS 'FSUBR (CADR F))) L)))
(DEFUN P1FAKE (X)
; Convert FOO into ((LAMBDA () FOO)) so that
; the setq count and clearing action of LAMBDA
; form will be done for FOO
((LAMBDA (F ZZ)
(SETQ ZZ (CDDAR F))
(RPLACA ZZ (ADD PROGN (CAR ZZ))) ;Make it appear as though
(RPLACA (CADDDR ZZ) (CAR X)) ; the unknown function is
(P1MODESET F)) ; of high "severity"
(P1VN (LIST (LIST 'LAMBDA () (CONS NULFU (CDR X)))))
() ))
(DEFUN P1FV (X)
(COND ((AND (CDR X) (CDDR X)) (P1FV (CDDR X)))
((CAR X))))
(DEFUN P1FUNGET (FUN) ;Idea is to convert '(LAMBDA . . .)
(PROG () ; to (FUNCTION (LAMBDA . . .))
A (COND ((ATOM FUN))
((EQ (CAR FUN) 'FUNCTION) (RETURN FUN))
((EQ (CAR FUN) 'QUOTE) (RETURN (CONS 'FUNCTION (CDR FUN))))
((NOT (EQ (SETQ FUN (P1MACROGET FUN)) NULFU)) (GO A)))))
(DEFUN P1GFY (X FL)
(COND ((ATOM X) X)
('T (SETQ X (COMPILE (P1PFX) FL X () 'T))
(AND (NOT FASLPUSH) (ICOUTPUT GOFOO))
X)))
(DEFUN P1-PP (X) ;P1 for PUSH and POP
(COND ((EQ (CAR X) 'POP)
(COND ((OR (NULL (CADR X))
(NOT (SYMBOLP (CADR X)))
(AND (CADDR X) (NOT (SYMBOLP (CADDR X)))))
(PDERR X |POP requires (non-null) symbols for SETQing|)
'(PROG2 () '()))
((NULL (CDDR X))
(SUBST (CADR X) 'GL '(PROG2 () (CAR GL) (SETQ GL (CDR GL)))))
('T (SUBLIS (LIST (CONS 'GL (CADR X))
(CONS 'VL (CADDR X)))
'(PROG2 (SETQ VL (CAR GL) GL (CDR GL)) VL)))) )
((OR (NULL (CADDR X)) (NOT (SYMBOLP (CADDR X))))
(PDERR X |PUSH requires 2nd arg to be a (non-null) symbol for SETQing|)
''())
((LIST 'SETQ (CADDR X) (LIST 'CONS (CADR X) (CADDR X))))))
(DEFUN P1PFX () (MAKNAM (APPEND GENPREFIX (EXPLODEC (SETQ GFYC (ADD1 GFYC))))))
(DEFUN P1GLM (LL BODY)
((LAMBDA (T1 MODE FL)
(COND ((NULL (CDR BODY))
(SETQ T1 (P1 (CAR BODY)))
(SETQ BODY (COND (ARITHP (CAR T1)) (T1))))
('T (SETQ BODY (P1L BODY EFFS ARITHP KTYPE))
(SETQ T1 (CAR (SETQ FL (LAST BODY))))
(AND ARITHP (RPLACA FL (CAR T1)))
(SETQ BODY (CONS PROGN BODY))))
(AND ARITHP (SETQ MODE (CDR T1) T1 (CAR T1)))
(NLNVASG P1LL)
(P1GLM1 LL
BODY
(COND ((OR EFFS (ZEROP (P1TRESS T1))) 0) (1))
(OR MODE KTYPE)
(COND ((NULL (SETQ FL (P2UNSAFEP T1))) () )
((ATOM FL) (LIST FL))
(FL))))
() () () ))
(DEFUN P1GLM1 (LL BODY N MODE UNSAFEP)
((LAMBDA (T1)
(COND ((NOT ARITHP) T1)
((CONS T1 MODE))))
(LIST 'LAMBDA N P1LSQ (CONS SPECVARS MODELIST) LL BODY CNT UNSAFEP NLNVTHTBP)))
(DEFUN P1LAM (F AARGS)
((LAMBDA (OLVRL P1LL RNL BVARS CONDP LMBP P1LSQ NLNVTHTBP
SPECVARS MODELIST TEM VSS VMS
BIND-ANALYZE-IN-OLD-ENV)
;Binding MODELIST, SPECVARS, RNL, and BVARS after making the funarg protects
; against spurious propogation of local declares
;WARNING! WARNING! Any variable augmented by local declaration
; part of P1LMBIFY must be so bound here.
(SETQ F (P1LMBIFY (CDDR F) 'P1LL P1LL P1LL () ))
(COND ((NOT (ZEROP (SETQ TEM (- (LENGTH AARGS) (LENGTH P1LL)))))
(PDERR (CONS (CONS 'LAMBDA (CONS P1LL F)) AARGS)
|Wrong number of args to LAMBDA|)
(DO ((Z) (I TEM (1- I)))
((SIGNP LE I)
(COND (Z (P1LMBIFY () () Z () () )
(SETQ P1LL (NCONC Z P1LL)))))
(PUSH (GENSYM) Z))))
(SETQ VSS (MAPCAR '(LAMBDA (X) (PUSH (VARMODE X) VMS)
(SPECIALP X))
P1LL)
VMS (NREVERSE VMS))
(SETQ AARGS (FUNCALL BIND-ANALYZE-IN-OLD-ENV VSS P1LL AARGS VMS))
(SETQ TEM (P1GLM P1LL F))
(P1SPECIALIZEDVS) ;CHECK FOR SCREW CASE
(SETQ CNT (1+ CNT))
(SETQ AARGS (COND (ARITHP (RPLACA TEM (CONS (CAR TEM) AARGS)))
((CONS TEM AARGS))))
(AND (SETQ F (UUVP 'P1LL)) (WARN F |Unused LAMBDA variables|))
(SETQ F P1LSQ))
(LJOIN OLVRL P1LL) (CADR F) RNL BVARS () 'T () ()
SPECVARS MODELIST () () ()
(*FUNCTION (LAMBDA (VSS P1LLCEK AARGS VMS)
(MAPCAR 'P1BINDARG VSS P1LLCEK AARGS VMS))))
(P1SQE F)
AARGS)
(DEFUN P1KNOWN (F L)
(AND (NOT (ATOM F))
(MEMQ (CAR F) '(QUOTE FUNCTION))
(ATOM (SETQ F (CADR F)))
(SETQ L (GETL F L))
(OR (NOT (MEMQ (CAR L) '(SUBR FSUBR LSUBR)))
(SYSP (CADR L)))))
(DEFUN P1L (X OEFFS OARITHP OKTYPE)
((LAMBDA (EFFS ARITHP KTYPE)
(MAPLIST '(LAMBDA (X)
(AND (NULL (CDR X))
(SETQ EFFS OEFFS ARITHP OARITHP KTYPE OKTYPE))
(P1 (CAR X)))
X))
'T () () ))
(DEFUN P1LST (X)
(PROG (Z LL V)
(SETQ Z (CDR X))
(COND ((MEMQ (CAR X) '(MEMBER ASSOC SASSOC)) ;CONVERT TO MEMQ, ASSQ, SASSQ IF POSSIBLE
(AND (OR (NULL (CADR Z)) (QNILP (CADR Z)))
(RETURN (P1 (LIST 'PROG2 (CAR Z) () ))))
(AND (COND ((P1EQQTE (CAR Z)))
((NULL (SETQ LL (P1LST-LSTGET (CADR Z)))) () )
((NOT (DO Y LL (CDR Y) (NULL Y)
(AND (NOT (SYMBOLP (COND ((EQ (CAR X) 'MEMBER) (CAR Y))
('T (CAAR Y)))))
(RETURN 'T))))))
(SETQ X (CONS (CDR (ASSQ (CAR X) '((MEMBER . MEMQ)
(ASSOC . ASSQ)
(SASSOC . SASSQ))))
(CDR X))))))
(COND ((NOT (AND EFFS
(EQ (CAR X) 'MEMQ)
(OR LL (SETQ LL (P1LST-LSTGET (CADR Z))))
(LESSP (LENGTH LL) 5))))
((P1CARCDR-CHASE (SETQ V (CAR Z)))
(RETURN (P1 (CONS 'OR (MAPCAR '(LAMBDA (X) (LIST 'EQ V (LIST 'QUOTE X))) LL)))))
((COND ((EQ (CAR V) 'SETQ) (SETQ LL V V (NX2LAST V)) 'T)
((AND (EQ (CAR V) 'PROG2)
(AND (CDDR V) (NULL (CDDDR V)))
(P1CARCDR-CHASE (CADDR V)))
(SETQ LL (CADR V) V (CADDR V))
'T))
(RETURN (P1 (LIST 'PROG2 LL (CONS 'MEMQ (CONS V (CDR Z))))))))
(SETQ X (CONS (CAR X) (MAPCAR 'P1VN (CDR X))))
(RETURN (COND (ARITHP (NCONS X)) (X)))))
(DEFUN P1LST-LSTGET (Z)
(COND ((OR (ATOM Z) (NOT (EQ (CAR Z) 'QUOTE))) () )
((NULL (CADR Z)) () )
((NOT (EQ (TYPEP (CADR Z)) 'LIST)) (PDERR Z |Cant use this as 2nd arg to MEMQ|))
((CADR Z))))
;WARNING WARNING!! P1LAM must bind any global lists which are augmented here.
(DEFUN P1LMBIFY (EXP VAR LL NAME TYPES)
(COND ((AND (NOT (ATOM (CAR EXP))) (EQ (CAAR EXP) 'DECLARE))
(MAPC '(LAMBDA (DATA)
(DO ((X (CDR DATA) (CDR X)) (TEMP) (ATOMP)) ;fix up for renamings of varialbes
((NULL X))
(COND ((SETQ TEMP (ASSQ (COND ((SETQ ATOMP (ATOM (CAR X)))
(CAR X))
((CAAR X)))
RNL))
(RPLACA (COND (ATOMP X) ((CAR X))) (CDR TEMP)))))
(AND (COND ((EQ (CAR DATA) 'SPECIAL))
((MEMQ (CAR DATA) '(FIXNUM FLONUM NOTYPE)))
('T (PDERR DATA |Illegal local declaration|) () ))
(MAPC '(LAMBDA (X)
(COND ((ATOM X)
(COND ((AND (MEMQ X BVARS)
(NOT (MEMQ X LL)))
(PDERR DATA |Local declaration occurs too late in function|)
() )
((EQ (CAR DATA) 'SPECIAL)
(REMPROP X 'OHOME)
(AND (NOT (GET X 'SPECIAL))
(PUSH (CONS X (LIST 'SPECIAL X))
SPECVARS)))
((AND (GET X 'NUMVAR)
(EQ (GET X 'NUMVAR) (CAR DATA))))
((PUSH (CONS X (COND ((EQ (CAR DATA) 'NOTYPE) () )
((CAR DATA))))
MODELIST))))
((VARMODE (CAR X))
(PDERR DATA |Cant locally redeclare function|))
((AND (NULL (CDR X)) (EQ (CAR DATA) 'NOTYPE)))
((PUSH (CONS (LIST (CAR X)) (NMPSUBST (CDR X) (CAR DATA))) MODELIST))))
(CDR DATA))))
(CDAR EXP))
(SETQ EXP (CDR EXP))))
(SET VAR
(MAPLIST
'(LAMBDA (Y)
(COND ((NULL (CAR Y)))
((OR (MEMQ (CAR Y) '(T QUOTE))
(NOT (SYMBOLP (CAR Y))))
(PDERR (LIST (CAR Y) 'FROM NAME)
|Not permissible in bound variable list|))
((MEMQ (CAR Y) (CDR Y))
(WARN (LIST (CAR Y) 'FROM NAME)
|- Repeated in bound variable list|
3 6)))
(COND ((NULL (SETQ Y (CAR Y))))
((SPECIALP Y))
((AND SPECIALS (NOT (GET Y 'P1M-NOSPEC)))
(PUTPROP Y (LIST 'SPECIAL Y) 'SPECIAL))
('T (COND ((ASSQ Y LOCVARS)
(PUSH (CONS Y (GENSYM)) RNL)
(AND (SETQ Y (VARMODE Y))
(PUSH (CONS (CDAR RNL) Y) MODELIST))
(SETQ Y (CDAR RNL))))
(PUTPROP Y () 'OHOME) ;Just to be sure that OHOME prop exists
(PUSH (CONS Y 0) LOCVARS)))
(AND Y (PUSH Y BVARS))
(COND (TYPES (AND Y (CAR TYPES)
(NOT (EQ (CAR TYPES) (VARMODE Y)))
(PUSH (CONS Y (CAR TYPES)) MODELIST))
(POP TYPES)))
Y)
LL))
EXP)
(DEFUN P1M-NOSPEC ()
((LAMBDA (X)
(AND SPECIALS (PUTPROP X 'T 'P1M-NOSPEC))
X)
(GENSYM)))
(DEFUN P1MACROGET (X)
;(NOT (ATOM X)) This has been ascertained in all the places of call
(COND ((NOT (SYMBOLP (CAR X))) NULFU)
(((LAMBDA (Z)
(COND ((AND (NULL Z) (NULL (SETQ Z (GET (CAR X) 'MACRO))))
NULFU)
((NOT (ATOM (SETQ Z (ERRSET (FUNCALL Z X) 'T))))
(CAR Z))
((EQ Z GOFOO) (PDERR X |Incorrect DO format|) ''() )
('T (PDERR X |LISP error during MACRO expansion|) ''() )))
(CDR (ASSQ (CAR X) MACROLIST))) )))
(DEFUN MACRO-EXPAND (X)
(COND ((OR (ATOM X) (MEMQ (CAR X) '(QUOTE COMMENT DECLARE DEFPROP)))
X)
(((LAMBDA (MCX-TRACE)
(COND ((EQ (CATCH (MCX-TRACE X) MCX-TRACE) CLPROGN)
(SETQ MCX-TRACE ())
(MCX-TRACE X))
('T X)))
'T))))
(DEFUN MAP-MCX-TRACE (L)
(AND L
(DO ((ANS) (TEM))
((NULL L) (NREVERSE ANS))
(SETQ TEM (MCX-TRACE (CAR L)))
(AND (NULL MCX-TRACE) (PUSH TEM ANS))
(POP L))))
(DEFUN MCX-TRACE (X)
(COND ((OR (ATOM X) (EQ (CAR X) 'QUOTE))
X)
(((LAMBDA (Y Z)
(COND ((ATOM (CAR X))
(COND ((NOT (SYMBOLP (CAR X))) X)
((GET (CAR X) '*FEXPR) X)
((OR (SYSP (GET (CAR X) 'FSUBR))
(EQ (CAR X) 'LAMBDA))
(CASEQ (CAR X)
((SETQ PROG LAMBDA ARRAY SIGNP ARRAYCALL
SUBRCALL LSUBRCALL STATUS SSTATUS)
;All but first one or two args are eval'd
(SETQ Y (MAP-MCX-TRACE (CDDR X)))
(COND (MCX-TRACE ())
((CONS (CAR X) (CONS (CADR X) Y)))))
((COND)
(CONS 'COND (MAPCAR 'MAP-MCX-TRACE (CDR X))))
((DO CASEQ)
(SETQ X (COND ((EQ (CAR X) 'DO) (P1DO X))
('T (P1CASEQ X))))
(AND (NULL X) (THROW () MCX-TRACE))
(MCX-TRACE X))
((GO AND OR FUNCTION ERRSET ERR STORE
PROGV *CATCH *THROW CATCH-BARRIER
CATCHALL UNWIND-PROTECT)
;All args eval'd
(MAP-MCX-TRACE X))
((CATCH THROW PUSH)
;First arg is eval'd, second quoted.
(SETQ Y (MCX-TRACE (CADR X)))
(SETQ Z (MAP-MCX-TRACE (CDDDR X)))
(COND (MCX-TRACE ())
((CONS (CAR X)
(CONS Y
(CONS (CADDR X) Z))))))
((DEFUN)
(AND (MEMQ (CAR (SETQ Y (CDDR X)))
'(EXPR FEXPR MACRO))
(SETQ Z (SETQ Y (CDR Y))))
(SETQ Y (MAP-MCX-TRACE (CDR Y)))
(COND (MCX-TRACE ())
((CONS
(CAR X)
(CONS
(CADR X)
(CONS
(CADDR X)
(COND ((NULL Z) Y)
((CONS (CADDDR X) Y)))))) )))
((DECLARE COMMENT DEFPROP
POP FASLOAD INCLUDE UWRITE UREAD
UCLOSE UKILL UAPPEND UPROBE CRUNIT
BREAK EDIT GCTWA)
X)
(T (BARF X |Unknown FSUBR in MCX-TRACE|))))
('T (SETQ Y (P1MACROGET X))
(COND ((EQ Y NULFU) (MAP-MCX-TRACE X))
(MCX-TRACE (THROW CLPROGN MCX-TRACE))
('T (MCX-TRACE Y))))))
((EQ (CAAR X) 'LAMBDA)
(SETQ Y (MAP-MCX-TRACE (CDDAR X))
Z (MAP-MCX-TRACE (CDR X)))
(COND (MCX-TRACE ())
((CONS (CONS 'LAMBDA (CONS (CADAR X) Y)) Z))))
('T (SETQ Y (MCX-TRACE (CAR X))
Z (MAP-MCX-TRACE (CDR X)))
(COND (MCX-TRACE ())
((CONS Y Z))))))
() ()) )))
(DEFUN P1MODESET (XPR)
(COND ((NOT ARITHP) XPR)
('T ((LAMBDA (TEMP FORM)
(CONS XPR
(COND ((ATOM FORM) (VARMODE FORM))
((AND (NOT (SETQ TEMP (ATOM (CAR FORM))))
(NOT (EQ (CAAR FORM) 'LAMBDA)))
() )
((COND ((NOT TEMP) ;Implies a LAMBDA
(SETQ FORM (CADDR (CDDDAR FORM)))
(AND (NOT (ATOM FORM))
(EQ (CAR FORM) PROGN)
(SETQ FORM (CAR (LAST FORM))))
(COND ((ATOM FORM) (SETQ TEMP (VARMODE FORM)) 'T)
((NOT (ATOM (CAR FORM))) (SETQ TEMP () ) 'T)))
((EQ (CAR FORM) 'ARRAYCALL) (SETQ TEMP (CADR FORM)) 'T))
TEMP)
((SETQ TEMP (OR (GET (CAR FORM) 'NUMFUN) (FUNMODE (CAR FORM))))
(CADR TEMP)))))
() XPR))))
(DEFUN P1MAP (X Z)
(PROG (Y TEM CCSLD FUN)
A (SETQ Y () CCSLD 'T)
(COND ((SETQ TEM (ATOM (SETQ FUN (CAR X))))) ;Random variable function
((MEMQ (CAR FUN) '(QUOTE FUNCTION))
(SETQ Y (COND ((SETQ TEM (ATOM (CADR FUN)))
(SETQ CCSLD (NOT (P1KNOWN (CADR FUN) '(SUBR FSUBR LSUBR))))
'T)
((EQ (CAADR FUN) 'LAMBDA)))))
((NOT (EQ (SETQ FUN (P1MACROGET FUN)) NULFU))
(SETQ X (CONS FUN (CDR X)))
(GO A)))
(AND Y ;CONVERT '(LAMBDA FOO)
(NULL TEM)
(EQ (CAAR X) 'QUOTE) ;INTO (FUNCTION (LAMBDA FOO))
(SETQ X (CONS (LIST 'FUNCTION (CADAR X)) (CDR X))))
(AND Y
(OR (AND MAPEX (NOT (AND Y TEM (GETL (CADAR X) '(FSUBR *FEXPR)))))
(AND (NOT TEM)
(EQ (CATCH (SETQ X (CONS (LIST 'QUOTE
((LAMBDA (CFVFL) (P1GFY (CADAR X) 'LEXPR))
(CONS (CONS BVARS RNL) CFVFL)))
(CDR X)))
CFVFL)
'CFVFL)))
(GO MAPEXPAND))
(AND CCSLD (P1SQV PROGN))
(RETURN
(P1FAKE
(CONS (CONS
MAKUNBOUND
(CONS '*MAP (CONS CCSLD
(COND ((OR (CDDR X) (NULL (CDR Z))) Z)
('T (CADR Z))))))
X)))
MAPEXPAND
(COND ((EQ (CAR Z) 'MAPATOMS)
(AND (NULL (CDR X)) (SETQ X (CONS (CAR X) '(OBARRAY))))
(SETQ TEM (SUBLIS (LIST (CONS 'PVR (CAR X)) (CONS 'STSL (CADR X)) (CONS 'VL (GENSYM)))
'(DO VL (- (CADR (ARRAYDIMS STSL)) 129.) (1- VL) (MINUSP VL)
(DECLARE (FIXNUM VL))
(MAPC PVR (ARRAYCALL T STSL VL)))))
(RETURN ((LAMBDA (MAPEX) (P1 TEM)) 'T))))
(SETQ TEM () ) ;To look for MAPC's for value!!
((LAMBDA (FORM INDICL) ;INDICL is the DO indices list, FORM is the format
(RPLACD (CAR MAPSB) INDICL) ;Install indices list in substition list
(RPLACD (CADR MAPSB) ;Install the exit test
(LIST (COND ((NULL (CDR INDICL)) (LIST 'NULL (CAAR INDICL)))
((CONS 'OR (MAPCAR '(LAMBDA (X) (LIST 'NULL (CAR X)))
INDICL))))))
(RPLACD (CAR (SETQ Y (CDDR MAPSB)))
(CONS (CADAR X)
(MAPCAR '(LAMBDA (X) (COND ((EQ (CADDDR Z) 'LIST) (CAR X))
((LIST 'CAR (CAR X)))))
INDICL)))
(COND ((NOT EFFS)
(SETQ Y (CDR Y)) ;POSITION Y OVER ((PVR) (STSL) . . .)
(COND (TEM (RPLACD (CAR Y) (CAR TEM))
(RPLACD (CADR Y) (CDR TEM)))
('T (RPLACD (CAR Y) (P1M-NOSPEC))
(RPLACD (CADR Y) (P1M-NOSPEC))))))
;Format of MAPSB is ((VL . NIL) (EXIT . NIL) (USR . NIL)
; (PVR . NIL) (STSL . NIL) (GOFOO . GOFOO))
(SETQ X (SUBLIS MAPSB FORM))) ;Substitute into the expander form
(COND (EFFS '(DO VL EXIT USR)) ;If not for value, then simple DO
((EQ (CADDR Z) 'MAP)
(SETQ TEM (CONS (P1M-NOSPEC) (CADR X))) ;This will be value for PVR below
(SETQ X (CONS (CAR X) (CONS (CAR TEM) (CDDR X))))
;STSL will become the first of the list being mapped down
'((LAMBDA (PVR) (DO VL EXIT USR) PVR) STSL))
((EQ (CADDR Z) 'MAPCON)
'((LAMBDA (PVR STSL)
(GOFOO PVR STSL)
(DO VL EXIT (SETQ STSL (LAST (RPLACD STSL USR))))
PVR)
() () ))
('((LAMBDA (PVR STSL)
(GOFOO PVR STSL)
(DO VL EXIT (SETQ STSL (CDR (RPLACD STSL (LIST USR)))))
PVR)
() () )))
(MAPCAR '(LAMBDA (Z) (LIST (SETQ Y (P1M-NOSPEC)) Z (LIST 'CDR Y))) (CDR X)))
(RETURN (P1 X))))
(DEFUN P1PROG (X)
(PROG2 (AND (OR (NULL (CDR X)) (AND (CAR X) (ATOM (CAR X))))
(DBARF X |Is this a PROG?|))
((LAMBDA (OPVRL SPECVARS MODELIST RNL BVARS PROGP EFFS P1PCX OARITHP PKTYP)
(PROG (CONDP P1CSQ LMBP P1LSQ PVRL P1VARS GL P1CNT KTYPE
ARITHP GONE2 P1PSQ BODY PRSSL PROGTYPE PROGUNSF NLNVTHTBP)
(AND P1LL (NOT (MEMQ P1LL OPVRL)) (PUSH P1LL OPVRL))
(SETQ X (P1LMBIFY (CDR X)
'PVRL
(SETQ P1VARS (SETQ PVRL (CAR X)))
P1VARS
() ))
(SETQ PVRL (DELQ () PVRL))
(SETQ P1VARS LOCVARS)
(SETQ P1CNT (SETQ CNT (ADD1 CNT)))
(SETQ BODY
(MAPCAR
'(LAMBDA (Y)
(PROG ()
(SETQ CNT (ADD1 CNT))
A (COND ((SETQ BODY (ATOM Y)))
((EQ (SETQ BODY (P1MACROGET Y)) NULFU)
(SETQ BODY () ))
((QNILP BODY) (SETQ BODY () ))
('T (SETQ Y BODY) (GO A)))
(COND (BODY
(SETQ PRSSL 'T)
(SETQ Y (P1TAG Y))
(SETQ GL (PUSH (CONS Y (GENSYM)) GL))
(AND (ASSQ Y (CDR GL))
(NOT (EQ Y GOFOO))
(WARN Y |Repeated GO tag|))
(RETURN Y))
('T (RETURN (P1E1 Y))))))
X))
(P1SPECIALIZEDVS) ;CHECK FOR SCREW CASE
(P1BUG P1CNT P1VARS)
(AND (SETQ X (UUVP 'PVRL)) (WARN X |Unused PROG variables|))
(COND ((MEMQ GOFOO GONE2)) ;GOFOO ON GONE2 SAYS THERE IS A COMPUTED GO
('T (MAPC '(LAMBDA (TAG) (AND (NOT (MEMQ (CAR TAG) GONE2))
(SETQ GL (DELETE TAG GL))))
GL)))
(SETQ GL (NREVERSE GL))
(MAPC '(LAMBDA (TAG) (COND ((NOT (ATOM TAG))
(MAPC 'P1TAGDEFP (CAR TAG)))
('T (P1TAGDEFP TAG))))
GONE2)
(SETQ X P1PSQ)
(NLNVASG PVRL)
; HERE IS RETURN VALUE, PUT IN GONE2
(SETQ GONE2 (LIST 'PROG P1PCX X GL (CONS SPECVARS MODELIST)
PVRL BODY PROGUNSF NLNVTHTBP))
(RETURN (COND ((NULL OARITHP) GONE2)
((CONS GONE2 (COND ((NULL (CAR PROGTYPE)) PKTYP)
((EQ (CAR PROGTYPE) (CADR PROGTYPE))
(CAR PROGTYPE))
(PKTYP))))))))
(COND (PVRL (CONS PVRL OPVRL)) (OPVRL))
SPECVARS MODELIST RNL BVARS 'T 'T 0 ARITHP KTYPE)
(P1SQE X)
(COND (PROGP (SETQ P1PSQ (LADD (LSUB X PVRL) P1PSQ))))))
(DEFUN P1GO (X)
(P1SQG X)
(COND ((ATOM (CADR X))
(AND (NOT (SYMBOLP (CADR X)))
(SETQ X (CONS 'GO (CONS (P1TAG (CADR X)) (CDDR X)))))
(PUSH (CADR X) GONE2)
X)
('T (COND ((ATOM (CADDR X)) (PUSH GOFOO GONE2))
('T (SETQ GONE2 (APPEND (CADDR X) GONE2))))
(CONS 'GO (CONS (P1VN (CADR X)) (CDDR X))) )))
(DEFUN P1RETURN (X)
(P1SQG X)
(COND ((OR (NULL (CDR X)) (NULL (CADR X)) (QNILP (CADR X)))
(SETQ PROGTYPE (P1TYPE-ADD PROGTYPE () ))
(COND (ARITHP '( (RETURN '() ) . () ))
('T '(RETURN '() ))))
(((LAMBDA (T1 MODE UNSAFEP)
(SETQ T1 ((LAMBDA (ARITHP PNOB EFFS KTYPE)
(P1 (CADR X)))
'T () () PKTYP))
(SETQ MODE (CDR T1) T1 (CAR T1))
(AND (NOT (ZEROP (P1TRESS T1)))
(SETQ P1PCX (ADD1 P1PCX)))
(SETQ PROGTYPE (P1TYPE-ADD PROGTYPE MODE))
(COND ((NULL (SETQ UNSAFEP (P2UNSAFEP T1)))
(SETQ UNSAFEP (AND (NOT (QNP T1)) (NOT (SYMBOLP T1)) 'T)))
((SETQ PROGUNSF (COND ((ATOM T1)
(OR (MEMQ T1 PVRL) ;If returning a PROG number var
(SETQ UNSAFEP () )) ; then allow NLNFINDCR below
(ADD T1 PROGUNSF))
('T (AND (LAND T1 PROGUNSF)
(SETQ PROGUNSF (ADD PROGN PROGUNSF)))
(LADD T1 PROGUNSF))))))
(SETQ T1 (LIST 'RETURN T1))
(COND (ARITHP (CONS T1 () )) (T1)))
() () () ))))
(DEFUN P1TAG (X)
((LAMBDA (TYPE)
(COND ((EQ TYPE 'SYMBOL) X)
((MEMQ TYPE '(FIXNUM FLONUM))
((LAMBDA (*NOPOINT BASE) (IMPLODE (EXPLODEC X))) 'T 10.))
('T (PDERR X |Not acceptable as GO tag|) GOFOO)))
(TYPEP X)))
(DEFUN P1TAGDEFP (TAG)
(AND (NOT (ASSQ TAG GL))
(NOT (EQ TAG GOFOO))
(PDERR (LIST 'GO TAG) |GO to non-existent tag|)))
(DEFUN P1PROG2 (XPR)
(DO ((TYPE) (T1) (T2) (OEFFS EFFS) (EFFS 'T) (OARITHP ARITHP) (ARITHP))
()
(SETQ T1 (P1 (CAR XPR)))
(COND ((NULL OEFFS)
(SETQ ARITHP OARITHP EFFS () )
(SETQ T2 (P1 (CADR XPR)))
(AND ARITHP (SETQ TYPE (CDR T2) T2 (CAR T2) ARITHP () ))
(SETQ EFFS 'T))
('T (SETQ T2 (P1 (CADR XPR)))))
(SETQ T2 (CONS 'PROG2 (CONS T1 (CONS T2 (MAPCAR 'P1 (CDDR XPR))))))
(RETURN (COND ((NOT OARITHP) T2) ((CONS T2 TYPE))))))
(DEFUN P1PROGN (X FUN)
(SETQ X (CONS FUN (P1L X EFFS ARITHP KTYPE)))
(AND ARITHP
((LAMBDA (LL MODE)
(SETQ MODE (CDAR LL))
(RPLACA LL (CAAR LL))
(SETQ X (CONS X MODE)))
(LAST X) () ))
X)
(DEFUN P1SETQ (X)
(PROG (VAR VAL LCP SPFL)
(SETQ LCP () )
(DO ((ZZ (CDR X) (CDDR ZZ)) (ARITHP)) ((NULL ZZ))
(COND ((NULL (CDR ZZ)) (RETURN (SETQ LCP () )))
((COND ((NOT (SYMBOLP (CAR ZZ)))
(PDERR X |Non-SYMBOL for assignment in SETQ|)
(SETQ VAR (GENSYM))
'T)
((MEMQ (CAR ZZ) '(T NIL))
(PDERR X |Dont SETQ T or NIL|)
(SETQ VAR (COPYSYMBOL (CAR ZZ) () ))
'T))
(SETQ ZZ (CONS VAR (CDR ZZ)))))
(COND ((AND (NULL (CDDR ZZ))
(OR (EQ (CAR ZZ) (CADR ZZ))
(AND (NOT (ATOM (CADR ZZ)))
(EQ (CAADR ZZ) 'PROG2)
(EQ (CAR ZZ) (CADDR (CADR ZZ))))))
(SETQ X '(PROG2))
(SETQ LCP (LIST (COND ((NULL LCP) ''() )
((CONS 'SETQ (NREVERSE LCP))))
(P1 (CADR ZZ)))) ;(SETQ Y Y) => (PROG2 () Y)
(RETURN () ))) ;(SETQ A B Y Y) => (PROG2 (SETQ A B) Y)
(SETQ VAR (COND ((CDR (ASSQ (CAR ZZ) RNL))) ;(SETQ Y (PROG2 C Y D)) ==>
((CAR ZZ)))) ; (PROG2 () (PROG2 C Y D))
;(SETQ A B Y (PROG2 C Y D)) =>
(P1SQV VAR) ; (PROG2 (SETQ A B) (PROG2 C Y D))
(SETQ VAL (P1BINDARG (SETQ SPFL (P1SPECIAL VAR)) VAR (CADR ZZ) (VARMODE VAR)))
(SETQ CNT (PLUS 2 CNT))
(AND (NOT SPFL) (RPLACD (ASSQ VAR LOCVARS) CNT))
(SETQ LCP (CONS VAL (CONS VAR LCP))))
(AND (NULL LCP) (PDERR X |Wrong number of args to SETQ|))
(SETQ VAR (CADR LCP)) ;REGARDLESS OF CONDITION BELOW, THIS GETS THE NAME OF
(AND (NOT (EQ (CAR X) 'PROG2)) ;THE VARIABLE WHOSE VALUE IS BEING RETURNED
(SETQ LCP (NREVERSE LCP)))
(SETQ LCP (CONS (CAR X) LCP))
(RETURN (COND ((NOT ARITHP) LCP)
((CONS LCP (VARMODE VAR)))))))
(DEFUN P1SIGNP (X)
((LAMBDA (TEST ARG)
(COND ((NULL TEST) (PDERR X |Bad args to SIGNP|) ''() )
((NOT (MEMQ (CDR TEST) '(T NIL)))
(SETQ ARG (P1VAP ARG 'T))
(COND ((NULL (CDR ARG))
(LIST 'SIGNP (CAR TEST) (CAR ARG)))
('T (SETQ ARG (LIST (CDR TEST) (CDR ARG) (CAR ARG)))
(AND (MEMQ (CAR TEST) '(N GE LE))
(SETQ ARG (LIST 'NULL ARG)))
ARG)))
('T (P1 (LIST 'PROG2 ARG (CDR TEST))))))
(ASSQ ((LAMBDA (OBARRAY) (INTERN (CADR X))) SOBARRAY)
'((N . ZEROP) (E . ZEROP) (G . PLUSP) (LE . PLUSP)
(L . MINUSP) (GE . MINUSP) (- . NIL) (A . T)))
(CADDR X)))
(DEFUN P1SPECIAL (X)
(COND ((EQ X 'QUOTE) (DBARF X |Can't be used as a variable - you lose.|))
((SPECIALP X))
((COND ((NOT (MEMQ X BVARS)))
(SPECIALS (NOT (GET X 'P1M-NOSPEC))))
(CKCFV X)
(PUTPROP X (LIST 'SPECIAL X) 'SPECIAL)
(COND ((NULL SPECIALS)
#(WARN X |Undeclared - taken as SPECIAL|)
(PUSH X P1SPECIALIZEDVS)
(COND ((REMPROP X 'OHOME)
((LAMBDA (Y) (AND Y (SETQ LOCVARS (DELQ Y LOCVARS))))
(ASSQ X LOCVARS))))))
(GET X 'SPECIAL))
('T (RPLACD (COND ((ASSQ X LOCVARS)) ((BARF X |Lost LOCVAR - P1SPECIAL|)))
CNT)
() )))
(DEFUN P1SPECIALIZEDVS ()
(DO ((LL P1SPECIALIZEDVS (CDR LL)) (TEM) (Z))
((NULL LL)
(AND Z (DBARF Z |These variables must be declared special by user
- the code for this function will probably not be correct|))
(SETQ P1SPECIALIZEDVS () )
Z)
(COND ((SETQ TEM (ASSQ (CAR LL) LOCVARS))
(SETQ LOCVARS (DELQ TEM LOCVARS))
(COND ((SETQ TEM (ASSQ (CAR LL) RNL))
(SETQ RNL (DELQ TEM RNL))
(PUSH (CONS (CDR TEM) (LIST 'SPECIAL (CDR TEM)))
SPECVARS)
(AND (SETQ TEM (ASSQ (CDR TEM) LOCVARS))
(SETQ LOCVARS (DELQ TEM LOCVARS)))))
(PUSH (CAR LL) Z)))))
(DEFUN P1SQE (L)
; Extend SETQ vars from inner PROG, COND, or LAMBDA to
; the outer CONDs and any outer LAMBDAs
(COND (L (COND (CONDP (SETQ P1CSQ (LADD L P1CSQ))))
(COND (LMBP (SETQ P1LSQ (LADD (LSUB L P1LL) P1LSQ))))))
() )
(DEFUN P1SQG (Z)
(COND ((NOT PROGP) (PDERR Z |GO or RETURN not in PROG|)))
(SETQ PRSSL 'T)
(P1SQV GOFOO))
(DEFUN P1SQV (Y)
(COND (CONDP (SETQ P1CSQ (ADD Y P1CSQ))))
(COND ((AND LMBP (NOT (MEMQ Y P1LL))) (SETQ P1LSQ (ADD Y P1LSQ))))
(COND ((AND PROGP (NOT (EQ Y GOFOO)) (NOT (MEMQ Y PVRL)))
(SETQ P1PSQ (ADD Y P1PSQ)))))
(DEFUN P1STATUS (X)
(PROG (Z Y TEM)
(COND ((ZEROP (GETCHARN (CADR X) 6)) (SETQ TEM () ))
((SETQ TEM (EXPLODEN (CADR X)))
(AND (CDDDDR TEM)
(RPLACD (CDDDDR TEM) () ))))
(AND (NOT (MEMQ ((LAMBDA (OBARRAY)
(SETQ Y (COND (TEM (IMPLODE TEM))
((INTERN (CADR X))))))
SOBARRAY)
(COND ((EQ (CAR X) 'STATUS) (CAR STSL))
((CADR STSL)))))
(WARN X |Possibly illegal STATUS call| 3 5))
(COND ((AND (SETQ TEM (CDDR X))
(SETQ Z (GET Y 'STATUS))
(SETQ Z (COND ((EQ (CAR X) 'STATUS) (CAR Z))
((CDR Z))))
(COND ((AND (EQ Z 'A) (MAPCAN 'P1STVAL TEM (CAR COMAL)))
(SETQ TEM (MAPCAR 'P1STQLIFY TEM))
'T)
;LIKE ([S]STATUS FOO VALUE1)
;OR ([S]STATUS FOO VALUE1 VALUE2)
((AND (EQ Z 'B)
(OR (P1STVAL (CAR TEM) 'T)
(MAPCAN 'P1STVAL (CDR TEM) (CAR COMAL))))
(SETQ TEM (CONS (COND ((SYMBOLP (CAR TEM))
(LIST 'QUOTE (CAR TEM)))
('T (P1VN (CAR TEM))))
(AND (CDR TEM)
(CONS (P1STQLIFY (CADR TEM))
(AND (CDDR TEM)
(LIST (LIST 'QUOTE
(CADDR TEM))))))))
T)))
;LIKE (SSTATUS MACRO D VALUE1)
(SETQ Z (CONS 'CONS (CONS (LIST 'QUOTE (CADR X))
(LIST (P1ITERLIST TEM () ))))))
('T (SETQ Z (LIST 'QUOTE (CDR X)))))
(RETURN Z)))
(DEFUN P1STVAL (X IPN)
((LAMBDA (Y)
(COND ((EQ Y 'SYMBOL)
(COND ((OR IPN (MEMQ X '(T NIL)) (SPECIALP X)) () )
('T (AND (SETQ Y (ASSQ X RNL))
(SETQ X (CDR Y)))
(COND ((MEMQ X BVARS) (LIST 'T))
('T (P1SPECIAL X) () )))))
((EQ Y 'LIST)
(AND (NOT (MEMQ (CAR X) '(QUOTE FUNCTION)))
(LIST 'T)))))
(TYPEP X)))
(DEFUN P1STQLIFY (X)
(P1VN (SUBST X 'X (COND ((NOT (P1STVAL X () )) '(QUOTE X))
('(LIST 'QUOTE X))))))
;;; CONDTYPE AND PROGTYPE HAVE A VERY RIGID FORMAT:
;;; ()
;;; ( () )
;;; (FIXNUM FIXNUM)
;;; (FLONUM FLONUM)
;;; (FIXNUM FLONUM)
;;; (() FIXNUM)
;;; (() FLONUM)
;;; (() FIXNUM FLONUM)
(DEFUN P1TYPE-ADD (TYPEL TYP)
(COND ((NULL TYPEL)
(SETQ TYPEL (COND ((EQ TYP 'FIXNUM) '(FIXNUM FIXNUM))
((EQ TYP 'FLONUM) '(FLONUM FLONUM))
( '( () ) ))))
((CDDR TYPEL))
((NULL (CAR TYPEL))
(COND ((NULL TYP))
((CDR TYPEL) (AND (NOT (EQ TYP (CADR TYPEL)))
(SETQ TYPEL '(() FIXNUM FLONUM))))
('T (SETQ TYPEL (COND ((EQ TYP 'FIXNUM) '(() FIXNUM))
('(() FLONUM)))))))
((NOT (EQ (CAR TYPEL) (CADR TYPEL)))
(AND (NULL TYP) (SETQ TYPEL '(() FIXNUM FLONUM))))
(TYP (AND (NOT (EQ (CAR TYPEL) TYP)) (SETQ TYPEL '(FIXNUM FLONUM))))
('T (SETQ TYPEL (COND ((EQ (CADR TYPEL) 'FIXNUM) '(() FIXNUM))
('(() FLONUM))))))
TYPEL)
(DEFUN P1TRESS (F) ;F HAS ALREADY BEEN P1'D
(COND ((OR (ATOM F)
(MEMQ (CAR F) '(QUOTE FUNCTION *FUNCTION EQ GO RETURN))
(AND (GET (CAR F) CARCDR)
(NOT (AND (NOT (ATOM (CAR F))) (EQ (CAAR F) CARCDR) (< (LENGTH (CDAR F)) 4)))))
0)
((MEMQ (CAR F) '(RPLACD RPLACA))
(COND ((AND (NOT (ZEROP (P1TRESS (CADR F))))
(ZEROP (P1TRESS (CADDR F))))
1)
(0)))
((MEMQ (CAR F) '(MEMQ SETQ)) (COND ((NOT (ZEROP (P1TRESS (CADDR F)))) 1) (0)))
((MEMQ (CAR F) '(COND PROG)) (CADR F))
((EQ (CAAR F) 'LAMBDA) (CADAR F))
((AND (EQ (CAR F) 'NULL) (P1BOOL1ABLE (CADR F))) 0)
((MEMQ (CAR F) '(AND OR)) (BARF F |AND or OR loss - P1TRESS|))
(1)))
(DEFUN P1VAP (XPR OPNOB) ;P1 for value, arithmetics, and PNOB supplied
((LAMBDA (ARITHP PNOB EFFS KTYPE) (P1 XPR)) 'T OPNOB () () ))
(DEFUN P1VN (XPR) ;P1 for value, no arithmetics
((LAMBDA (ARITHP EFFS KTYPE) (P1 XPR)) () () () ))
(COMMENT NLNVTHTBP VARIABLE HACKERY)
(DEFUN NLNVASG (VARS)
(DO ((X NLNVS (CDR X)) (FL))
((NULL X) (AND FL (SETQ NLNVS (DELQ () NLNVS))))
(COND ((MEMQ (CAAR X) VARS)
(PUSH (CDAR X) NLNVTHTBP)
(PUTPROP (CDAR X) () 'OHOME)
(PUSH (CONS (CDAR X) CNT) LOCVARS)
(SETQ FL 'T)
(RPLACA X () ))
((AND (NOT (MEMQ (CAAR X) BVARS))
(NOT (MEMQ (CAAR X) P1LLCEK))
(NOT (MEMQ (CAAR X) ROSENCEK)))
(WARN (CAR X) |Show JONL - NLNVASG|)))))
(DEFUN NLNVFINDCR (MODE TYPE)
(NLNVCR (COND ((AND (NOT (EQ PNOB 'T)) PNOB))
((COND ((NULL PNOB) () )
((AND (NOT (EQ TYPE 'PROG)) (CAR (OR P1LL PVRL))))
((CAAR OPVRL))))
((CAR (PUSH (GENSYM) ROSENCEK))))
MODE))
(DEFUN NLNVCR (VAR MODE)
((LAMBDA (NAME)
(PUTPROP NAME MODE 'NUMVAR)
(PUSH (CONS VAR NAME) NLNVS)
NAME)
(INTERN (GENSYM))))
(DEFUN NLNVEX (VAR ITEM) ;CALLED ONLY BY P1BINDARG
(COND ((AND ITEM (NOT (EQ ITEM 'T))) ;ONLY CALLED WHERE ITEM IS RESULT OF P2UNSAFEP
(SETQ UNSFLST (ADD VAR UNSFLST))
(COND ((ATOM ITEM) (NLNV1 VAR ITEM NLNVS))
('T (MAPC '(LAMBDA (OLDVAR) (NLNV1 VAR OLDVAR NLNVS)) ITEM))))))
(DEFUN NLNV1 (NEWVAR OLDVAR SHEE-IT)
(AND (MEMQ NEWVAR (MEMQ OLDVAR BVARS))
(DO ((Y SHEE-IT (CDR Y)) (ITEM))
((NULL Y))
(COND ((EQ (CAAR Y) OLDVAR)
(PUTPROP OLDVAR NEWVAR 'NLNVS)
(RPLACA (CAR Y) NEWVAR))
((EQ (CAAR Y) (SETQ ITEM (GET OLDVAR 'NLNVS)))
(NLNV1 NEWVAR ITEM Y))))))
(COMMENT SOME TYPE ANALYZERS USED BY PHASE 1)
;Basically, P1 type analyzers, where XPR has not yet been P1'd
(DEFUN NUMTYP (XPR NUMBERP)
(SETQ XPR (NUMTYPEP XPR NUMBERP))
(AND (MEMQ (CDR XPR) '(FIXNUM FLONUM)) XPR))
(DEFUN NUMTYPEP (XPR NUMBERP) ;Returns form actually found to be of numeric type [except for
; a numeric constant, in which case 1 or 1.0 is used] CONS'd to type
((LAMBDA (TYPE)
(COND ((EQ TYPE 'FIXNUM) '(1 . FIXNUM))
((EQ TYPE 'FLONUM) '(1.0 . FLONUM))
((EQ TYPE 'SYMBOL) (AND (SETQ TYPE (VARMODE XPR)) (CONS XPR TYPE)))
((NOT (EQ TYPE 'LIST)) () )
((EQ (SETQ TYPE (TYPEP (CAR XPR))) 'LIST)
(COND ((EQ (CAAR XPR) 'LAMBDA) ;### this fails when ret val depends on
(NUMTYPEP (CAR (LAST (CDDAR XPR))) NUMBERP)) ; local vars and declarations
((EQ (CAAR XPR) COMP)
(WARN XPR |Let JONL see this code - NUMTYPEP|)
(AND (MEMQ (CADAR XPR) '(FIXNUM FLONUM))
(CONS XPR (CADAR XPR))))))
((NOT (EQ TYPE 'SYMBOL)) () )
((EQ (CAR XPR) 'SETQ)
(SETQ XPR (NX2LAST (CDR XPR)))
(AND (SETQ TYPE (NUMERVARP XPR)) (CONS XPR TYPE)))
((EQ (CAR XPR) 'QUOTE)
(COND ((EQ (SETQ XPR (TYPEP (CADR XPR))) 'FIXNUM) '(1 . FIXNUM))
((EQ XPR 'FLONUM) '(1.0 .FLONUM))))
((EQ (CAR XPR) 'PROG2) (NUMTYPEP (CADDR XPR) NUMBERP))
((MEMQ (CAR XPR) '(PROGN PROGV))
(NUMTYPEP (CAR (LAST (CDR XPR))) NUMBERP))
((EQ (CAR XPR) 'DO) ;### SEE THE CAVEAT ON LAMBDAS ABOVE
(AND (NOT (ATOM (CADR XPR))) ;### ALSO FAILS ON PROGS TOO
(SETQ TYPE (CAR (LAST (CADDR XPR))))
(OR (ATOM TYPE) (NOT (QNILP TYPE)))
(NUMTYPEP TYPE NUMBERP)))
((EQ (CAR XPR) 'COND)
(COND (NUMBERP (DO ((Y (CDR XPR) (CDR Y)))
((NULL Y) (SETQ TYPE () ))
(AND (SETQ TYPE (CDR (NUMTYP (CAR (LAST (CAR Y))) 'T)))
(RETURN () ))))
('T (SETQ TYPE () )
(DO ((Y (CDR XPR) (CDR Y)) (FL))
((NULL Y))
(SETQ FL
(CDR (NUMTYPEP (CAR (LAST (CAR Y)))
() )))
(COND ((NULL FL) (RETURN (SETQ TYPE () )))
((NULL TYPE) (SETQ TYPE FL))
((NOT (MEMQ TYPE '(FIXNUM FLONUM))))
((EQ TYPE FL))
('T (SETQ TYPE 'T))))))
(AND TYPE (CONS XPR TYPE)))
((SETQ TYPE (NUMFUNP XPR 'T)) (CONS XPR TYPE))
((NOT (EQ (SETQ TYPE (P1MACROGET XPR)) NULFU))
(NUMTYPEP TYPE NUMBERP))))
(TYPEP XPR)))
;;;A subroutine for P1CJ-NUMVALP and NUMTYPEP - argument must be a list with
;;; a SYMBOL as first element.
;;; Wants to ascertain if the "function" is guaranteed to producee a manageable
;;; numerical result. Thus PLUS isn't generally so, since it can produce a
;;; BIGNUM, or perhaps the type is not fixable at compile time.
(DEFUN NUMFUNP (FORM P1P)
(COND ((MEMQ (CAR FORM) '(ARRAYCALL LSUBRCALL SUBRCALL))
(AND (MEMQ (CADR FORM) '(FIXNUM FLONUM)) (CADR FORM)))
(((LAMBDA (PROP)
(COND ((NULL PROP)
(AND (SETQ PROP (FUNMODE (COND ((SETQ PROP (ASSQ (CAR FORM) RNL)) (CDR PROP))
((CAR FORM)))))
(CADR PROP)))
((OR (EQ (CAR PROP) 'ARITHP) (EQ (CAR PROP) 'NUMFUN)) (CADADR PROP))
((EQ (CAR PROP) 'NUMBERP)
(COND ((EQ (CADR PROP) 'NOTYPE) () )
((OR FIXSW (EQ (CAR FORM) 'HAULONG)) 'FIXNUM)
((OR FLOSW (EQ (CAR FORM) 'FLOAT)) 'FLONUM)
((NOT P1P)
(COND ((OR (EQ (CAR FORM) 'FIX) (NULL (CADR FORM)))
() ) ;For NUMVALP, we dont care to know the "T" types
((MEMQ (CADR FORM) '(FIXNUM FLONUM))
(CADR FORM))
(CLOSED () )
((GET (CAR FORM) 'CONTAGIOUS)
(AND (MEMQ 'FLONUM (CADR FORM)) 'FLONUM))))
(CLOSED () )
((GET (CAR FORM) 'CONTAGIOUS)
(DO ((Y (CDR FORM) (CDR Y))
(ANS 'FIXNUM))
((NULL Y) ANS)
(SETQ PROP (CDR (NUMTYPEP (CAR Y) 'T)))
(COND ((EQ PROP 'FLONUM) (RETURN 'FLONUM))
((NOT (EQ PROP 'FIXNUM)) (SETQ ANS 'T)))))
('T (SETQ PROP (CDR (NUMTYPEP (CADR FORM) 'T)))
(COND ((AND (EQ (CAR FORM) 'FIX)
(NOT (EQ PROP 'FIXNUM)))
'T)
(PROP))) ))))
(GETL (CAR FORM) '(ARITHP NUMFUN NUMBERP))))))
(DEFUN NUMERVARP (VAR) (AND (SYMBOLP VAR) (VARMODE VAR)))
(DEFUN NOTNUMP (X) ;PHASE2 analyzer for something proveably not a FIXNUM or FLONUM
(COND ((ATOM X) () )
((NOT (ATOM (CAR X)))
(COND ((EQ (CAAR X) '*MAP))
((EQ (CAAR X) 'LAMBDA) (NOTNUMP (CADDDR (CDDAR X))))))
((EQ (CAR X) 'QUOTE)
#(LET ((TYP (TYPEP (CADR X))))
(CASEQ TYP
((FIXNUM FLONUM) () )
(LIST (NOT (EQ (CAADR X) SQUID)))
(T T))))
((EQ (CAR X) 'PROG2) (NOTNUMP (CADDR X)))
((OR (EQ (CAR X) 'PROGN)
(EQ (CAR X) PROGN)
(EQ (CAR X) 'PROGV)
(EQ (CAR X) 'IOG))
(NOTNUMP (CAR (LAST (CDR X)))))
(((LAMBDA (FL)
(COND ((NULL FL) () )
((EQ (CAR FL) 'NOTNUMP))
((EQ (CAR FL) 'NUMBERP) (EQ (CADR FL) 'NOTYPE))
((EQ (CAR FL) 'ARITHP) (NULL (CADADR FL)))
((EQ (CAR FL) 'FSUBR)
(COND ((MEMQ (CAR X)
'(FASLOAD STORE STATUS SSTATUS SETQ
GO THROW ERR COND PROG POP
ARRAYCALL SUBRCALL LSUBRCALL
))
() )
('T)))
((NOT (EQ (CAR FL) 'MACRO)) () )
((EQ (CAR X) SQUID) () )
((NOT (EQ (SETQ FL (P1MACROGET X)) NULFU))
(NOTNUMP FL))))
(GETL (CAR X) '(NOTNUMP NUMBERP ARITHP FSUBR MACRO))))))
(DEFUN SAMETYPES (TYPEL) ;Will take a types list, e.g.
((LAMBDA (TYPE) ; (FIXNUM () FLONUM () FLONUM)
(DO L (CDR TYPEL) (CDR L) ; and convert it to an atom [one of
(COND ((NULL L) (SETQ TYPEL TYPE) 'T) ; (), FIXNUM, FLONUM] if all types
((NOT (EQ TYPE (CAR L))))))) ; are the same
(CAR TYPEL))
TYPEL)
(DEFUN P2UNSAFEP (XPR) ;PHASE2 analyzer, for something that might be a PDL number
(COND ((ATOM XPR)
(AND (COND ((MEMQ XPR UNSFLST))
((NOT (NUMERVARP XPR)) () )
((NOT (SPECIALP XPR))))
XPR))
((NOT (ATOM (CAR XPR)))
(AND (EQ (CAAR XPR) 'LAMBDA) (CADDDR (CDDDDR (CAR XPR)))))
((EQ (CAR XPR) 'PROG) (CADDDR (CDDDDR XPR)))
((MEMQ (CAR XPR) '(AND OR COND)) (CADDDR XPR))
((EQ (CAR XPR) 'SETQ) (P2UNSAFEP (NX2LAST (CDR XPR))))
((EQ (CAR XPR) 'PROG2) (P2UNSAFEP (CADDR XPR)))
((OR (EQ (CAR XPR) 'PROGN) (EQ (CAR XPR) PROGN))
(P2UNSAFEP (CAR (LAST (CDR XPR)))))
((EQ (CAR XPR) 'ARG) ARGLOC)))
(DEFUN UUVP (VAR)
((LAMBDA (LL)
((LAMBDA (L)
(COND (L (SET VAR (LSUB LL (CONS () L))) L)
((MEMQ () LL) (SET VAR (LSUB LL '(()) ))) )
L)
(MAPCAN '(LAMBDA (X)
(COND ((AND X (SETQ X (ASSQ X LOCVARS)) (= (CDR X) 0))
(LIST (COND ((ASSOCR (CAR X) RNL)) ((CAR X)))) )))
LL)))
(SYMEVAL VAR)))
(DEFUN CKARGS (NAME M)
((LAMBDA (AARGS)
(COND ((NULL AARGS) (PUTPROP NAME (CONS () M) 'ARGS))
((AND (NULL (CAR AARGS)) (= (CDR AARGS) M)))
(#(WARN NAME |Has been previously used with incorrect
number of args -- Discovered while |))))
(OR (ARGS NAME) (GET NAME 'ARGS))))
(DEFUN CKCFV (X)
(COND (SPECIALS)
(CFVFL (MAPC '(LAMBDA (Y) (AND (OR (MEMQ X (CAR Y)) (ASSQ X (CDR Y)))
(THROW 'CFVFL CFVFL)))
CFVFL)
() )
((AND P1GFY (OR (MEMQ X BVARS) (ASSQ X RNL)))
(DBARF X |Used free inside a LAMBDA form - must be declared special|))))
(DEFUN WRNTYP (NAME)
#(WARN NAME |Has been incorrectly declared *EXPR or *FEXPR -- Discovered while |)
(LREMPROP NAME '(*EXPR *FEXPR *LEXPR ARGS)))
(COMMENT CHOMP - COMPILE ONE FUNCTION IN CORE)
(DEFUN CHOMP FEXPR (L)
(DECLARE (SPECIAL LAPLL DATA FASLPUSH SYMBOLS CREADTABLE TOPFN
CFVFL BARFP COMPILER-STATE CURRENTFNSYMS LOC FILOC
CURRENTFN MAINSYMPDL SYMPDL UNFASLCRFL UNFASLSIGNIF
ENTRYNAMES ALLATOMS LITLOC DDTSYMP ATOMINDEX SYMBOLSP
LITERALS UFFIL))
(AND (NOT (GET 'LAP-A-LIST 'SUBR))
(+INTERNAL-AUTOLOAD (CONS 'LAP (GET 'LAP 'AUTOLOAD))))
((LAMBDA (VL MSGFILES LAPLL DATA FASLPUSH SYMBOLS READTABLE TOPFN
BARFP COMPILER-STATE ↑W ↑Q ↑R CURRENTFNSYMS LOC FILOC
CURRENTFN MAINSYMPDL SYMPDL UNFASLCRFL UNFASLSIGNIF
ENTRYNAMES ALLATOMS LITLOC DDTSYMP ATOMINDEX SYMBOLSP
LITERALS)
(SETQ L (MAPCAN '(LAMBDA (X)
(COND ((GETL X '(EXPR FEXPR))
(AND (SETQ DATA (GETL X '(SUBR FSUBR LSUBR)))
(NOT (SYSP X))
(REMPROP X (CAR DATA)))
(LIST X))))
L))
(COND (VL (SETQ FASLPUSH 'T)
(FASL-START VL NIL)
(LAP-FILE-MSG (CONS '|##IN-CORE-FUNCTIONS##| L)
(CONS TYO UFFIL))))
(MAPC '(LAMBDA (X)
(SETQ DATA (GETL X '(EXPR FEXPR)) CFVFL NIL LAPLL NIL)
(COMPILE X (CAR DATA) (CADR DATA) NIL NIL)
(AND VL (LAPSETUP/| NIL NIL))
(LAP-A-LIST (SETQ LAPLL (NREVERSE LAPLL)))
(AND (COND ((SYSP X)
(AND (SETQ DATA (GETL X '(EXPR FEXPR SUBR FSUBR LSUBR)))
(MEMQ (CAR DATA) '(EXPR FEXPR))
(SETQ DATA '(SUBR FSUBR LSUBR))))
(T (AND (SETQ DATA (GETL X '(*EXPR *FEXPR *LEXPR SUBR FSUBR LSUBR)))
(MEMQ (CAR DATA) '(SUBR FSUBR LSUBR))
(SETQ DATA '(*EXPR *FEXPR *LEXPR)))))
(SETQ DATA (CAR (GETL X DATA)))
(PUTPROP X (CAR (REMPROP X DATA)) DATA))
(COND (VL (FASLAPSETUP/| NIL) (FASLIFY LAPLL 'LIST)))
(SETQ LAPLL NIL))
L)
(AND VL (FASL-CLOSEOUT VL '((|##IN-CORE-FUNCTIONS##|)) VL))
L)
(COND ((NOT (ATOM (CAR L))) (PROG2 () (CAR L) (SETQ L (CDR L)))))
'(T) () () 'T SYMBOLS CREADTABLE () 'T 'COMPILE
() () () () () () () () () () () () () () ()
() () () ))
(COMMENT FILE-TRANSDUCERS)
(DEFUN CMP1 () ;Transduce a file compileing those sexps which try to define functions
((LAMBDA (SYMBOLS READTABLE OBARRAY MSGFILES)
(PROG (ERRFL X NAME NAMEFORM DECLARATION-FLAGCONVERSION-TABLE FL FORM IRASLOSS PRATTSTACK PXHFL)
(SETQ DECLARATION-FLAGCONVERSION-TABLE
'((*FEXPR . FEXPR) (*EXPR . EXPR) (*LEXPR .EXPR)))
(AND RECOMPL
(MAP '(LAMBDA (L) (AND (NOT (EQ (CAR L) (SETQ X (INTERN (CAR L)))))
(RPLACA L X)))
RECOMPL))
A (COND (PRATTSTACK (SETQ FORM (CAR PRATTSTACK) PRATTSTACK (CDR PRATTSTACK)))
((EQ GOFOO (SETQ FORM (COND (READ (FUNCALL READ GOFOO))
('T (READ GOFOO)))))
(AND FASLPUSH LAPLL (TERFASL))
(RETURN GOFOO)))
(AND CHOMPHOOK (MAPC '(LAMBDA (F) (FUNCALL F FORM)) CHOMPHOOK))
B (COND ((ATOM FORM) (GO ICF))
((EQ (CAR FORM) 'DEFPROP)
(SETQ X (CDDR FORM) FL (CADR X) NAME (CADR FORM))
(COND ((OR (NULL (CDR X)) (CDDR X) (NOT (SYMBOLP NAME)))
(GO GH))
((OR (ATOM (CAR X)) (NOT (EQ (CAAR X) 'LAMBDA)))
(GO ICF))
((EQ FL 'MACRO)
(CMP1-MACRO-ENLIVEN (CONS 'DEFUN
(CONS NAME
(CONS 'MACRO
(CDAR X))))))
((ASSQ FL COMPILATION-FLAGCONVERSION-TABLE)
(SETQ FORM (CONS 'DEFUN
(CONS NAME
(CONS FL
(CDAR X)))))
(GO B))
((AND (SETQ X (GETL NAME '(*EXPR *FEXPR *LEXPR)))
(NOT (EQ FL (CDR (ASSQ (CAR X) DECLARATION-FLAGCONVERSION-TABLE)))))
(WRNTYP NAME)
(PUTPROP NAME 'T (CAAR (ASSOCR FL DECLARATION-FLAGCONVERSION-TABLE)))))
(GO ICF))
((EQ (CAR FORM) 'DEFUN)
(AND (OR (NULL (CDR FORM)) (NULL (CDDR FORM)) (NULL (CDDDR FORM)))
(GO GH))
(COND ((SYMBOLP (SETQ NAME (CADR FORM))) (SETQ NAMEFORM () ))
((ATOM NAME) (GO GH))
('T (SETQ NAME (CAR (SETQ NAMEFORM NAME)))
(AND (COND ((NOT (SYMBOLP NAME)))
((NULL (CDR NAMEFORM)))
((NOT (SYMBOLP (CADR NAMEFORM))))
((NULL (CDDR NAMEFORM)) ())
((NOT (SYMBOLP (CADDR NAMEFORM)))))
(GO GH))))
(AND (NOT (MEMQ (SETQ FL (CADDR FORM)) '(FEXPR EXPR MACRO)))
(SETQ FORM (CONS 'DEFUN
(CONS NAMEFORM
(CONS (SETQ FL 'EXPR)
(CDDR FORM))))))
(AND (NULL (CDDDDR FORM)) (GO GH))
(AND NAMEFORM
(EQ (CADR NAMEFORM) 'MACRO)
(CMP1-MACRO-ENLIVEN (CONS 'DEFUN
(CONS NAME
(CONS 'MACRO
(CDDDR FORM))))))
(COND ((AND (NULL NAMEFORM) (EQ FL 'MACRO))
(CMP1-MACRO-ENLIVEN FORM))
((AND RECOMPL (NOT (MEMQ NAME RECOMPL))))
((ASSQ FL COMPILATION-FLAGCONVERSION-TABLE)
(SETQ UNDFUNS (DELQ NAME UNDFUNS))
(SETQ LAP-INSIGNIF () )
(SETQ PXHFL 'T)
(COND ((NULL NAMEFORM) (SETQ NAMEFORM NAME))
((NOT (ATOM NAMEFORM))
(COND ((NULL (CDDR NAMEFORM))
(SETQ NAME (PNAMECONC (CAR NAMEFORM)
'/
(CADR NAMEFORM)))
(ICOUTPUT (LIST 'DEFPROP
(CAR NAMEFORM)
NAME
(CADR NAMEFORM)))
(SETQ NAMEFORM NAME))
('T (SETQ PXHFL () ))) ))
(AND EXPR-HASH
PXHFL
(ICOUTPUT (LIST 'DEFPROP
NAME
(SXHASH (CONS 'LAMBDA (CDDDR FORM)))
'EXPR-HASH)))
((LAMBDA (COMPILER-STATE ↑W ↑R)
(COMPILE NAMEFORM
FL
(CONS 'LAMBDA (CDDDR FORM))
()
() )
(COND (TTYNOTES
(SETQ ↑W (SETQ ↑R () ))
(INDENT-TO-INSTACK 0)
(PRIN1 NAMEFORM)
(PRINC '| Compiled|)))
(SETQ ↑W (SETQ ↑R 'T))
(COND (FASLPUSH (AND LAPLL (TERFASL)))
('T (TYO 12.)))
(COND (TTYNOTES
(SETQ ↑W (SETQ ↑R () ))
(COND (FASLPUSH (PRINC '| and assembled |))
('T (TYO 32.))))))
'COMPILE ↑W ↑R)
(GO A))
('T (GO ICF) ))
(AND RECOMPL (GO A)))
((COND ((AND (EQ (CAR FORM) 'ARRAY) (SETQ NAME (CADR FORM)))
(MEMQ (SETQ FL (CADDR FORM)) '(T () FIXNUM FLONUM OBARRAY)))
((AND (EQ (CAR FORM) '*ARRAY)
(P1EQQTE (CADR FORM))
(SETQ NAME (CADADR FORM))
(COND ((MEMQ (SETQ FL (CADDR FORM)) '(T () )))
((P1EQQTE FL)
(MEMQ (SETQ FL (CADR FL))
'(T () FIXNUM FLONUM OBARRAY READTABLE)))))))
(AND (NOT (MEMQ FL '(FIXNUM FLONUM))) (SETQ FL 'NOTYPE))
(SETQ X (DO ((L (CDDDR FORM) (CDR L)) (Z) (T1))
((NULL L) (LIST (CONS NAME (NREVERSE Z))))
(COND ((OR (FIXP (SETQ T1 (CAR L)))
(AND (P1EQQTE T1) (FIXP (SETQ T1 (CADR T1)))))
(PUSH T1 Z))
('T (RETURN (LIST NAME (LENGTH (CDDDR FORM)))) ))))
(COND ((GET NAME '*ARRAY)
(PUTPROP NAME () '*ARRAY) ;To prevent spurious re-declared msgs
((LAMBDA (T1) (AND (COND (T1 (PUTPROP NAME () 'NUMFUN)
(COND ((CADR T1) (NOT (EQ (CADR T1) FL)))
((NOT (EQ FL 'NOTYPE)))))
((NOT (EQ FL 'NOTYPE))))
(PUTPROP NAME '(() () ) 'NUMFUN)))
(GET NAME 'NUMFUN))))
(AR*1 (CONS FL X))
(SETQ LAP-INSIGNIF () )
(COUTPUT FORM))
((EQ (CAR FORM) 'DECLARE)
(SETQ X INFILE)
(AND (NULL (ERRSET ((LAMBDA (COMPILER-STATE)
(MAPC 'EVAL (CDR FORM)))
'DECLARE)
'T))
(PDERR FORM |Declaration loses due to some error|))
(COND ((NOT (EQ INFILE X))
(MAPC '(LAMBDA (DATA)
(AND (FILEP DATA)
(SETQ X (CAR (STATUS FILEM DATA)))
(EQ (CAR X) 'IN) (EQ (CADR X) 'ASCII)
(NOT (EQ (CADDR X) 'TTY))
(EOFFN DATA 'COEFN)))
(CONS INFILE INSTACK))))
(GO A))
((EQ (CAR FORM) 'EVAL-WHEN) (APPLY 'EVAL-WHEN (CDR FORM)))
((COND (SAILP
(MEMQ (CAR FORM) '(REQUIRE INCLUDE)))
(T (EQ (CAR FORM) 'INCLUDE)))
(SETQ X INSTACK FL () )
(ERRSET (SETQ FL (EVAL FORM)) 'T) ;Try to "include" file
(COND (TTYNOTES
(PROG (↑W ↑R)
(INDENT-TO-INSTACK 1)
(PRINC (COND (FL '|;Including file |)
('T '|;Failure to include file |)))
(PRIN1 (TRUENAME FL)))))
(COND (FL (EOFFN FL 'COEFN))
('T (AND (NOT (EQ X INSTACK)) (INPUSH -1))
(PDERR FORM |File not included|)))
(GO A))
((EQ (CAR FORM) 'CGOL) (CGOL))
((EQ (CAR FORM) 'LAP)
(CMP-LAPFUN (CDR FORM))
(COND ((AND RECOMPL (NOT (MEMQ (CADR FORM) RECOMPL)))
(ZAP2NIL FORM () ))
(FASLPUSH (AND LAPLL (TERFASL))
(FASLIFY FORM 'LAP)) ;Hack the LAP code
('T (ZAP2NIL FORM 'T)
(AND TTYNOTES ((LAMBDA (↑R ↑W)
(PRINT (CADR FORM))
(PRINC '|LAP code zapped |))
() () )))) )
((AND (EQ (CAR FORM) 'LAP-A-LIST)
(NOT (ATOM (CADR FORM)))
(EQ (CAADR FORM) 'QUOTE)
(SETQ X (CADADR FORM))
(NOT (ATOM (CAR X)))
(EQ (CAAR X) 'LAP))
(CMP-LAPFUN (CDAR X))
(COND ((OR (NOT FASLPUSH)
(AND RECOMPL (NOT (MEMQ (CADAR X) RECOMPL))))
(ICOUTPUT FORM))
('T (AND LAPLL (TERFASL))
(FASLIFY X 'LIST))))
((AND FORM (ATOM (CAR FORM)) (SETQ FL (GET (CAR FORM) 'MACRO)))
(AND (OR (NULL (ERRSET (SETQ IRASLOSS (FUNCALL FL FORM) FL () )
'T))
FL)
(PDERR FORM |Error during top level MACRO expansion|))
(SETQ FORM IRASLOSS)
(GO B) ) ;Apply macro property and try again
((AND (EQ (CAR FORM) 'PROGN) ;(PROGN 'COMPILE . . .)
(NOT (ATOM (CADR FORM)))
(EQ (CAADR FORM) 'QUOTE)
(EQ (CADADR FORM) 'COMPILE))
(SETQ PRATTSTACK (APPEND (CDDR FORM) PRATTSTACK))
(GO A))
((NOT RECOMPL)
(SETQ LAP-INSIGNIF () )
(COUTPUT FORM)
(AND (EQ (CAR FORM) 'COMMENT) LAPLL (TERFASL)) ))
(AND (NOT FASLPUSH) (ICOUTPUT GOFOO))
(GO A)
ICF (SETQ LAP-INSIGNIF () )
(ICOUTPUT FORM)
(AND (NOT FASLPUSH) (PROG2 (ICOUTPUT NULFU) (ICOUTPUT GOFOO)))
(GO A)
GH (DBARF FORM |Illegal DEFUN format| 4 4) ))
SYMBOLS CREADTABLE COBARRAY CMSGFILES))
(DEFUN CMP1-MACRO-ENLIVEN (FORM)
;;; Expects input to be of form "(DEFUN name MACRO (var) . body)"
((LAMBDA (NAME BODY)
(COND (MACROS (ICOUTPUT FORM)
(SETQ LAP-INSIGNIF () ) ))
(COND ((LAND '(EXPR FEXPR SUBR FSUBR LSUBR AUTOLOAD)
(STATUS SYSTEM NAME))
(OR (GET NAME 'SKIP-WARNING)(WARN NAME
|being redefined as a MACRO by user file - /
definition is pushed on MACROLIST|))
(PUSH (CONS NAME BODY) MACROLIST))
('T (EVAL FORM))))
(CADR FORM) (CONS 'LAMBDA (CDDDR FORM))))
(DEFUN CL FEXPR (L) ;Compile a list of functions given by atom name
((LAMBDA (LAPLL DATA SYMBOLS READTABLE TOPFN COMPILER-STATE
GAG-ERRBREAKS TTYNOTES YESWARNTTY CMSGFILES
FASL FASLPUSH ASSEMBLE NOLAP)
(CONS 'COMMENT
(MAPCAR '(LAMBDA (J)
(AND (SETQ DATA (GETL J '(EXPR FEXPR)))
(PROG2 (SETQ CFVFL () TOPFN J)
(COMPILE J (CAR DATA) (CADR DATA) () () ))))
(SETQ CL (OR L CL)))))
() () SYMBOLS CREADTABLE () 'COMPILE () 'T 'T () () () () () ))
(DEFUN TERFASL ()
(FASLIFY (NREVERSE (PROG2 () LAPLL (SETQ LAPLL () )))
'LIST))
(DEFUN COEFN (FIL EOFVAL) ;Standard EOFFN for main
(AND (EQ FIL INFILE) (INPUSH -1)) ; input source file
(COND (TTYNOTES ;Pop file off stack
(PROG (↑W ↑R)
(INDENT-TO-INSTACK 0)
(PRINC '|;End Of File |)
(PRIN1 (NAMESTRING (TRUENAME FIL))))))
(AND (FILEP FIL) (CLOSE FIL)) ;Close file. If more is on
(COND (INSTACK 'T) ; stack, keep reading;
('T EOFVAL))) ; otherwise we have a real EOF
(DEFUN CMP-LAPFUN (X)
((LAMBDA (TYPE PROP)
(SETQ LAP-INSIGNIF () )
(SETQ UNDFUNS (DELQ (CAR X) UNDFUNS))
(COND ((OR (NULL TYPE) (AND PROP (NOT (EQ (CAR PROP) TYPE))))
(WRNTYP (CAR X)))
('T (PUTPROP (CAR X) TYPE 'T))))
(CDR (ASSQ (CADR X) '((SUBR . *EXPR) (FSUBR . *FEXPR) (LSUBR . *LEXPR))))
(GETL (CAR X) '(*EXPR *FEXPR *LEXPR))))
(DEFUN INDENT-TO-INSTACK (II) ;TERPRI and indent proportional to length of INSTACK
(TERPRI)
(DO ((N (- (LENGTH INSTACK) II 2) (1- N)))
((MINUSP N))
(PRINC '| |)))
(DEFUN LAP-FILE-MSG (REALI L)
((LAMBDA (TEM TERPRI OUTFILES)
(SETQ TEM (STATUS DATE))
(SETQ ↑W (SETQ ↑R 'T) LINE () )
(COND (FASLPUSH (UNFASL-MSG REALI))
('T (PRINC '|/
'(THIS IS THE LAP FOR |)
(PRIN1 REALI)
(PRINC '|)|)))
(PRINC '|/
'(COMPILED BY LISP COMPILER //|)
(PRINC COMPLRVERNO)
(PRINC '|)/
|)
(COND (TEM
((LAMBDA (BASE *NOPOINT APM II)
(PRINC '|;COMPILED ON |)
(COND ((AND ITSP (SETQ APM (STATUS DOW)))
(PRINC APM)
(SETQ APM 'AM)
(PRINC '|, |)))
(PRINC (CAR #(NCDR '(JANUARY FEBRUARY MARCH APRIL MAY JUNE
JULY AUGUST SEPTEMBER OCTOBER NOVEMBER DECEMBER)
(1- (CADR TEM)))))
(PRINC '| |)
(PRINC (CADDR TEM))
(PRINC '|, |)
(PRINC (+ 1900. (CAR TEM)))
(COND ((SETQ TEM (STATUS DAYTIME))
(PRINC '|, AT |)
(SETQ II (CAR TEM))
(COND ((ZEROP II)
(AND (= (CADR TEM) 0) (SETQ APM 'MIDNITE))
(PRINC '/12))
((= II 12.)
(SETQ APM (COND ((= (CADR TEM) 0) 'NOON)
('PM)))
(PRINC '/12))
('T (AND (> II 12.) (SETQ APM 'PM II (- II 12.)))
(PRINC II)))
(COND ((< (CADR TEM) 10.) (PRINC '/:/0))
('T (PRINC '/:)))
(PRINC (CADR TEM))
(PRINC '/ )
(PRINC APM)))
(TERPRI))
10. T 'AM 0)))
(SETQ LAP-INSIGNIF 'T))
() 'T L))
(DEFUN MAKLAP FEXPR (L)
(DECLARE ;Variables bound only for the benefit of FASLAP
(SPECIAL CURRENTFNSYMS LOC FILOC CURRENTFN MAINSYMPDL FBARP
UNFASLSIGNIF ENTRYNAMES SYMPDL LITLOC BINWORDS
ALLATOMS NUMBERTABLE ATOMINDEX DDTSYMP SYMBOLSP LITERALS
UFFIL IMOSAR))
(COND (FILESCLOSEP (SETQ CMSGFILES () ) (GC) (SETQ FILESCLOSEP () )))
((LAMBDA (EOC-EVAL RECOMPL LINEL READ OCMSGFILES INFILE IMOSAR)
(PROG (CH LINE INMLS ONMLS DEV USR TEM JCLP REALI II FSLNL
TOPFN SWITCHLIST OPNDP FASLERR COMPILER-STATE LAP-INSIGNIF
↑W ↑Q ↑R CURRENTFNSYMS LOC FILOC CURRENTFN MAINSYMPDL
UNFASLSIGNIF ENTRYNAMES ALLATOMS LITLOC FBARP NOC F-NOC
SYMPDL NUMBERTABLE ATOMINDEX DDTSYMP SYMBOLSP LITERALS
OUTFILES INSTACK UFFIL CMSGFILES FASLPUSH)
B0 (SETQ UNDFUNS () COMPILER-STATE 'MAKLAP FSLNL ()
REALI () FASLPUSH () LAP-INSIGNIF 'T FASLERR ()
CMSGFILES OCMSGFILES F-NOC () )
B (SETQ ↑W (SETQ ↑R (SETQ ↑Q () )))
(SETQ LINE (LIST 35397.) SWITCHLIST () INMLS () )
(COND (L (COND ((AND (CAR L) (ATOM (CAR L)))
(SETQ JCLP 'T LINE L L () )
(SSTATUS FEATURE NOLDMSG)
(GO A1))) ;Compilation begun from JCL
(AND (NOT DISOWNED) (TERPRI))
(MAKJPG (CAR L))
(COND ((CDR L)
(SETQ ONMLS (RDSYL))
(SETQ INMLS (MAPCAN '(LAMBDA (L) (MAKJPG L) (RDSYL))
(CDR L)))
(SETQ TEM (FASL-LAP-P)))
('T (SETQ INMLS (RDSYL))
(SETQ TEM (FASL-LAP-P))
(SETQ ONMLS (LIST (CONS (CAAR INMLS)
(CONS TEM
(CDDAR INMLS)))))))
(AND (OR (MEMQ () INMLS) (MEMQ () ONMLS))
(GO IIS))
(GO D1)))
(TERPRI)
(PRINC '/←)
(AND (NUMBERP (SETQ TEM (READLINE 'T 0))) (GO B))
(MAP '(LAMBDA (X) (AND (< 96. (CAR X))
(< (CAR X) 123.)
(RPLACA X (- (CAR X) 32.))))
(SETQ LINE (NRECONC (EXPLODEN TEM) LINE)))
A1 (SETQ TEM (RDSYL))
(COND ((NOT (LESSP 2 (SETQ II (LENGTH (CAR TEM))) 5)) ;TEM=(()) on detected errors
(GO IIS))
((= II 3)
(RPLACA TEM (CONS (CAAR TEM) (CONS (COND (ITSP '>) ('T '/ )) (CDAR TEM))))))
(SETQ INMLS (NCONC TEM INMLS))
(AND (= CH 44.) (GO A1)) ;Comma separates multiple sources
(COND ((= (CAR LINE) 35397.)
(SETQ ONMLS (LIST (CDDAR INMLS)) II 2)) ;If no sink, default DEV,USR to first source
((NOT (LESSP 1 (SETQ II (LENGTH (CAR (SETQ ONMLS (RDSYL))))) 5))
(GO IIS)))
(SETQ TEM (FASL-LAP-P))
(AND (NOT (= II 4))
(SETQ ONMLS (LIST (CONS (CAAR (COND ((= II 3) ONMLS) (INMLS)))
(CONS TEM (COND ((= II 3) (CDAR ONMLS)) ((CAR ONMLS))))))))
D1 (SETQ FASLPUSH (AND (NOT ASSEMBLE) NOLAP))
(SETQ DEV () USR () ) ;Do device and directory defaulting
(MAPC '(LAMBDA (X) (COND ((NULL (CADDR X))
(RPLACA (CDDR X) (COND (DEV) ((SETQ DEV 'DSK)))))
(ITSP (SETQ DEV (CADDR X))))
(COND ((NULL (CADDDR X))
(RPLACA (CDDDR X) (COND (USR) ((SETQ USR (STATUS UDIR))))))
(ITSP (SETQ USR (CADDDR X))))
() )
(APPEND ONMLS INMLS))
(SETQ FILESCLOSEP 'T)
(COND ((OR (AND SAILP (EQ (CADR (CAR INMLS)) '/>))
(APPLY 'UPROBE (CAR INMLS)))
(SETQ REALI (TRUENAME
(INPUSH
(COND (SAILP (EOPEN (UGREAT1 (DEFAULTF (CAR INMLS))) 'IN))
('T (OPEN (DEFAULTF (CAR INMLS)) 'IN))))))
(SETQ REALI (APPEND (CDR REALI) (CAR REALI)))
((LAMBDA (BASE *NOPOINT)
(SETQ GENPREFIX
(NCONC (COND ((NOT ITSP)
(NCONC (LIST '/[)
(EXPLODEC (CAR (CADDDR REALI)))
(LIST '/,)
(EXPLODEC (CADR (CADDDR REALI)))
(LIST '/])))
('T (NCONC (EXPLODEC (CADDDR REALI)) (LIST '/;))))
(EXPLODEC (CAR REALI))
'(/-))))
10. 'T))
((AND L (NOT JCLP)) (RETURN () ))
('T (PRIN1 (CAR INMLS))
(PRINC '| File Not Found - MAKLAP|)
(GO B0)))
(COND ((AND JCLP (OR TTYNOTES YESWARNTTY)) () )
((OR DISOWNED JCLP) (GIVUPTTY)))
(COND (ASSEMBLE (FASL-A-FILE (CAR ONMLS) INMLS)
(AND NOLAP
(NOT (MEMBER (CAR ONMLS) INMLS))
(MAPC 'UKILL INMLS))
(GO ENDUP)))
(COND (FASLPUSH (FASL-START (SETQ FSLNL (CAR ONMLS)) () ))
('T (AND FASL
(SETQ ONMLS (LIST (CONS (CAR (SETQ FSLNL (CAR ONMLS)))
(CONS 'LAP
(CONS 'DSK (CDDDAR ONMLS)))))))
(APPLY 'UWRITE (CDDAR ONMLS)) ;OPENS THE LAP OUTPUT FILE
(PUSH UWRITE CMSGFILES)
(LINEL UWRITE 80.)))
(AND (OR YESWARNTTY TTYNOTES)
(NOT (MEMQ TYO CMSGFILES))
(PUSH TYO CMSGFILES))
(SETQ OPNDP 'T)
D2 (COND ((NULL (CAR INMLS)) (WARN () |Phooey on JPG - MAKLAP|) (GO ENDUP)))
(SETQ NOC () )
(COND (OPNDP (SETQ OPNDP ())
(AND SAILP (EOPEN INFILE 'IN))
(SETQ REALI (LIST REALI)))
('T (APPLY 'EREAD (CAR INMLS))
(PUSH (STATUS UREAD) REALI)))
(AND TTYNOTES
(PROG (↑R ↑W)
(PRINC '|/
Compilation begun on |)
(PRIN1 (CAR REALI))
(PRINC '| |)))
(LAP-FILE-MSG (CAR REALI) (COND (FASLPUSH UFFIL) ;Sets LAP-INSIGNIF to T
('T (CONS UWRITE UFFIL)))) ; as well as ↑R ↑W
(SETQ ↑Q 'T)
C (SETQ TOPFN ()
TEM (COND ((OR (NOT (FILEP INFILE))
(NULL (STATUS FILEMODE INFILE)))
CLPROGN)
((ERRSET (CMP1) () ))))
(COND ((ATOM TEM)
(AND (EQ TEM 'FASLAP) (SETQ FASLERR 'T))
(COND (FASLPUSH)
('T ((LAMBDA (↑W ↑R)
(PRINC '| () |)
(TYO 12.))
'T 'T)))
(AND TOPFN (SETQ NOC (CONS TOPFN NOC))) ;NOC accumulates function names that cop out
(COND ((NULL TEM)
#(WARN (LIST (CONS 'TOPFN TOPFN)
(CONS
'FILEPOS
(COND ((OR (NOT (FILEP INFILE))
(NULL (STATUS FILEMODE INFILE)))
'CLOSED)
((FILEPOS INFILE)))))
|Lisp Error during file compilation|)
(MSOUT-BRK () SOBARRAY SREADTABLE 'LISP-ERROR)
(GO C))
((EQ TEM GOFOO)
#(DBARF INFILE |EOF encountered during READ,
possibly misbalanced paresn?|))
('T (GO C))) ))
(SETQ TOPFN () )
(COND (NOC
(SETQ NOC (NREVERSE NOC))
(SETQ F-NOC (NCONC F-NOC (APPEND NOC () )))
#(WARN NOC |- Failed to compile|)))
(COND ((SETQ INMLS (CDR INMLS)) (GO D2)))
(COND (UNDFUNS #(WARN UNDFUNS |have been used but remain undefined in this file|)))
(SETQ REALI (NREVERSE REALI))
(AND TTYNOTES
(PROG (↑Q ↑R ↑W)
(TERPRI)
(PRINT (COND ((CDR REALI) REALI) ((CAR REALI))))
(PRINC '| Finished compilation|)
(COND (F-NOC
(PRINC '|, but |)
(PRIN1 F-NOC)
(PRINC '| Failed to compile|)))
(PRINC '| |) ))
(COND (FASLERR
#(WARN () |/
**ERROR** FASL file aborted due to errors during FASLAP|)
(AND FASLPUSH (FASL-CLOSEOUT () () FSLNL)))
(FASLPUSH
(FASL-CLOSEOUT (CAR ONMLS)
(AND (NOT LAP-INSIGNIF) REALI)
FSLNL))
('T
(SETQ CMSGFILES (DELQ UWRITE CMSGFILES))
(COND ((AND SAILP (PROBEF (CAR ONMLS)))
(DELETEF (CAR ONMLS))))
(APPLY 'UFILE (CAR ONMLS)) ;CLOSEs LAP file
(SETQ ONMLS (NREVERSE ONMLS))
(AND FSLNL (FASL-A-FILE FSLNL ONMLS))))
(AND (FILEP INFILE) (CLOSE INFILE))
(SETQ FILESCLOSEP () )
ENDUP (MAPC 'EVAL EOC-EVAL)
(AND (OR JCLP DISOWNED) (QUIT))
EXIT (AND L (RETURN () ))
(GO B0)
IIS (PRINC '|INCORRECT COMMAND SYNTAX - MAKLAP|)
(GO EXIT) ))
EOC-EVAL
RECOMPL
120. ;LINEL
READ
CMSGFILES
'T ;INFILE
IMOSAR))
(DEFUN FASL-LAP-P ()
(AND INITIALIZE
(MAPC '(LAMBDA (X) (COND ((SYMBOLP X) (LOAD X))
('T (INITIALIZE))))
INITIALIZE))
(MAPC 'SETQ SWITCHLIST)
(COND ((OR ASSEMBLE NOLAP FASL) 'FASL) ('LAP)))
;Returns "LAP" iff this run is compile-only
(DEFUN GIVUPTTY ()
(SETQ GAG-ERRBREAKS (SETQ ↑W 'T) TTYNOTES () YESWARNTTY () )
(AND (MEMQ TYO CMSGFILES)
(SETQ CMSGFILES (DELQ TYO (APPEND CMSGFILES () ))))
(AND (MEMQ TYO MSGFILES)
(SETQ MSGFILES (DELQ TYO (APPEND MSGFILES () ))))
(AND (STATUS TTY)
(STATUS HACTRN)
(VALRET (COND (DISOWNED '|:PROCED :DISOWN |) ('|:PROCED |)))))
(DEFUN SPLITFILE FEXPR (L)
(COND ((OR ASSEMBLE (NULL L) (CDR L))
(SETQ L (CONS 'SPLITFILE L))
(COND (ASSEMBLE (PDERR L |SPLITFILE not yet implemented for A switch|))
((PDERR L |Lose lose - SPLITFILE|))))
((PROG2 (SETQ L (CONS (CAR L) (CDAR ONMLS))) FASLPUSH)
(FASL-CLOSEOUT (CAR ONMLS)
(COND (LAP-INSIGNIF (POP ONMLS) () ) ;() FLUSHES NULL FASL FILE
('T (TERFASL) (CAR ONMLS)))
() ) ;Dont close unfasl file
(FASL-START L 'T) ; but do continue it
(UNFASL-MSG L)
(PUSH L ONMLS))
('T (SETQ CMSGFILES (DELQ UWRITE CMSGFILES))
(APPLY 'UFILE (CAR ONMLS))
(COND (LAP-INSIGNIF (APPLY 'UKILL (CAR ONMLS)) (POP ONMLS)))
(APPLY 'UWRITE (CDDR L))
(LAP-FILE-MSG L (LIST UWRITE)) ;SETS LAP-INSIGNIF TO T
(PUSH L ONMLS)))) ;AS WELL AS ↑R ↑W
(DEFUN MAKJPG (L)
((LAMBDA (LL)
(SETQ LINE
(NREVERSE
(NCONC LINE
(EXPLODEN (CAR L))
(LIST 40)
(EXPLODEN (CADR L))
(LIST 40)
(COND (LL (NCONC (EXPLODEN (CAR LL)) (LIST 58. 32.))))
(COND ((AND LL (CDR LL))
(NCONC (EXPLODEN (CADR LL))
(LIST 59. 32.))))))))
(CDDR L)))
(DEFUN RDSYL ()
(PROG (L TEM)
(SETQ DEV (AND (NOT ITSP) 'DSK) USR () )
A (SETQ CH (CAR LINE))
(COND ((= CH 35397.) (GO RET))
((AND (NOT ITSP) (= CH 93.))
(POP LINE)
(SETQ USR (RDSYL2 'T))
(COND ((NULL USR)
(PRINC '/
/")
(PRINC (MAKNAM (CDR (REVERSE LINE))))
(PRINC '|" Has illegal PPN/
|)
(RETURN () ))))
((OR (FNCP CH) (= (CADR LINE) 47.))
(SETQ L (CONS (RDSYL2 () ) L)))
((= CH 58.)
(POP LINE)
(SETQ DEV (RDSYL2 () ))) ;Colon triggers dev name
((= CH 59.)
(POP LINE)
(SETQ USR (RDSYL2 () ))) ;Semi-colon triggers dir name
((= CH 41.) ;Rparen triggers switches
(COND ((NULL (SETQ TEM (RDSYL3 (CDR LINE))))
(PRINC '|/
"|)
(PRINC (MAKNAM (CDR (REVERSE LINE))))
(PRINC '|" Has illegal switch request/
|)
(RETURN () )))
(SETQ LINE (CDR TEM)) ;Strip off "("
(GO A)) ;FOO ")"
((OR (= CH 95.) (= CH 44.)) ;Left-arrow or comma
(POP LINE)
(GO RET))
((COND ((= CH 32.)) ;Space is file-name separator
((NOT ITSP) (= CH 46.))) ;and on DEC10, so is .
(POP LINE))
((< CH 32.) (POP LINE) (GO A))
('T (PRINC '/
/")
(TYO CH)
(PRINC '/"?/ ILGL/ CHAR/
)
(RETURN () )))
(GO A)
RET (RETURN (LIST (NCONC L (LIST DEV USR))))))
(DEFUN RDSYL2 (PPNP)
(PROG (Y Z PRJ)
A (SETQ Y (CAR LINE))
(COND ((= Y 35397.) (GO X))
((OR (= (CADR LINE) 47.) (= (CADR LINE) 17.)) (POP LINE)) ;"/" and ↑Q are escapes
((= Y 46.) (AND (NOT ITSP) (GO X))) ;"." is break on DEC10
((< Y 32.) (GO B))
((AND (NOT ITSP)
PPNP
(COND ((= Y 44.) (SETQ PRJ (RDSYLPPN Z) Z () ) (GO B) 'T) ;","
((= Y 91.) ;"["
(POP LINE)
(SETQ Z (RDSYLPPN Z))
(AND (OR (NULL Z) (NULL PRJ)) (RETURN () ))
(RETURN (LIST Z PRJ))
'T))))
((NOT (FNCP Y)) (GO X)))
(PUSH Y Z)
B (POP LINE)
(GO A)
X (AND PPNP (RETURN () ))
(RETURN (IMPLODE Z))))
(DEFUN RDSYLPPN (Z)
(COND ((STATUS FEATURE SAIL) (IMPLODE Z))
((DO ((N 0)) ((NULL Z) N) ;48. thru 57. are ASCII
(AND (OR (< (CAR Z) 48.) (> (CAR Z) 57.)) (RETURN () )) ; codes for the digits
(SETQ N (+ (* N 10.) (- (POP Z) 48.)))))))
(DEFUN RDSYL3 (L) ;MAKLAP COMMAND LINE SWITCH PARSER
(PROG (OBARRAY TEM)
(SETQ OBARRAY SOBARRAY)
A (COND ((= (CAR L) 40.) (RETURN L)) ;left parens
((NOT (> (CAR L) 32.))) ;ignore space and tab
((OR (= (CAR L) 95.) ;left-arrow
(> (CAR L) 127.)) ;end-of-line, or ??
(RETURN () ))
((= (CAR L) 93.) ;Aha!, a "]"
(POP L)
(DO ((Z))
((OR (NULL L) (= (CAR L) 91.)) ; so look for "["
(POP L)
(COND ((AND (CAR L) (OR (= (CAR L) 73.)
(= (CAR L) 105.))) ;Upper and lower case I
(POP L)
(PUSH (MAKNAM Z) INITIALIZE))))
(PUSH (POP L) Z))
(GO A))
((OR (= (CAR L) 73.) (= (CAR L) 105.)) ;Upper and lower case I
(PUSH '(T) INITIALIZE))
((SETQ TEM (ASSQ (ASCII (COND ((> (CAR L) 96.) (- (CAR L) 32.))
((CAR L))))
SWITCHTABLE))
(PUSH (LIST (CADR TEM)
(COND ((= (CADR L) 45.) (POP L) () ) ;- means set to ()
('T))) ;else set to T
SWITCHLIST))
('T (RETURN () ))) ;bomb out if not recognize
(POP L)
(GO A)))
(DEFUN FNCP (II) ;File-Name-Character-Predicate
(OR (LESSP 59. II 95.) ;Gets <, ?, @, A-Z, [, \, ], ↑
(LESSP 47. II 58.) ;Gets 0 - 9
(LESSP 32. II 40.) ;Gets ! to ' (Tops of 1 to 4)
(= II 43.) (= II 45.) ;Gets + and -
(COND ((NOT ITSP) () )
((OR (= II 42.) ;Gets *
(= II 46.)))))) ;Gets .
;;; (PNAMECONC 'ABC 'D '(C D) '(ASDF DDD ER) 'FOO) => ABCDCDASDFDDDER
;;; for each single-character symbol, a number in the ASCII range is ok.
(DEFUN PNAMECONC N
(PROG (ARGL LL)
(SETQ ARGL (LISTIFY N))
A (SETQ LL (MAPCAN '(LAMBDA (A) (COND ((ATOM A) (PCGAV A))
((MAPCAN 'PCGAV A))))
ARGL))
(COND ((MEMQ () LL) (SETQ ARGL (ERROR ARGL
'|Bad argument list - PNAMECONC|
'WRNG-TYPE-ARG))
(GO A)))
(RETURN (MAKNAM LL))))
(DEFUN PCGAV (A) ;Get the ASCII values for a list of chars
((LAMBDA (TP)
(COND ((AND (EQ TP 'SYMBOL) (NOT (= (GETCHARN A 2) 0))) (EXPLODEN A))
((LIST (COND ((EQ TP 'SYMBOL) (GETCHARN A 1))
((AND (EQ TP 'FIXNUM) (< 1 128.) (NOT (< A 0))) A)
('T () ))))))
(TYPEP A)))
(DEFUN REMPROPL (FL LL) (MAPC '(LAMBDA (X) (REMPROP X FL)) LL))
(DEFUN LREMPROP (NAME L)
(PROG (V FL)
A (SETQ V (GETL NAME L))
(AND (NULL V) (RETURN FL))
(COND ((REMPROP NAME (CAR V)) (SETQ FL 'T)))
(GO A)))
(DEFUN MSOUT (W MSG FLAG L1 L2)
(DECLARE (SPECIAL UNFASLSIGNIF))
(AND (NOT (AND (EQ FLAG 'WARN) (SYMBOLP W) (GET W 'SKIP-WARNING)))
#(LET ((OUTFILES CMSGFILES) (TERPRI 'T) (PRINLEVEL L1) (PRINLENGTH L2)
(BASE 10.) (*NOPOINT () ) (↑R 'T) (↑W 'T) (II 0))
(AND (COND ((OR YESWARNTTY (EQ FLAG 'BARF) (NULL OUTFILES)))
((MEMQ FLAG '(DATA ERRFL)) (NULL GAG-ERRBREAKS)))
(NOT (MEMQ TYO OUTFILES))
(NOT (MEMQ 'T OUTFILES))
(SETQ ↑W () ))
(AND (OR UNFASLCOMMENTS (NULL YESWARNTTY))
(SETQ UNFASLSIGNIF 'T))
(SETQ II (+ (COND ((MEMQ FLAG '(ERRFL DATA BARF))
(PRINC '|/
(COMMENT **ERROR** |)
20.)
('T (PRINC '|/
(COMMENT **** |) 15.))
(FLATSIZE W)
1
(FLATC MSG)))
(PRIN1 W)
(PRINC '| |)
(AND (> II 71.) (PRINC '|/
/ / |))
(PRINC MSG)
(COND ((AND TOPFN (NOT (EQ FLAG 'FASL)))
(PRINC '| in function |)
(PRIN1 TOPFN)))
(PRINC '/))
(COND ((MEMQ FLAG '(ERRFL DATA))
(COND ((NULL GAG-ERRBREAKS)
(PRINC '|/
; DATA ERROR - TO PROCEED TYPE $P |)
(MSOUT-BRK W COBARRAY CREADTABLE 'DATA)))
(COND ((EQ FLAG 'ERRFL) (SETQ ERRFL 'T))
('T (ERR 'DATA))))
((EQ FLAG 'BARF)
(PRINC '|/
;%%%%%%%% COMPILER ERROR - CALL JONL %%%%%%%% |)
(MSOUT-BRK W SOBARRAY SREADTABLE 'BARF)
(ERR 'BARF))))))
(DEFUN MSOUT-BRK (ARGS OBARRAY READTABLE FL)
(PROG (READ ↑R MSGFILES) (SETQ MSGFILES '(T)) (*BREAK 'T FL))
(TERPRI))
(DEFUN ZAP2NIL (DATA FL)
(DECLARE (SPECIAL LINEL) (FIXNUM LINEL CHAR))
(PROG (CHAR FLAG N LINEL ↑R ↑W)
(SETQ LINEL (LINEL UWRITE))
(SETQ ↑R (SETQ ↑W 'T))
(COND (FL (TERPRI)
(LINEL UWRITE 0.)
(PRINT DATA)))
A (SETQ CHAR (ZTYI))
(COND ((= CHAR 13.) ;<carriage-return>
(AND (= 10. (TYIPEEK)) (TYI)) ;flush any following line-feed
(SETQ FLAG () ))
(FLAG)
((= CHAR 47.) (AND FL (TYO CHAR)) (SETQ CHAR (ZTYI))) ; |/|
((= CHAR 59.) (SETQ FLAG 'T)) ; |;|
((= CHAR 40.) ; |(|
(AND (ZEROP N)
(= (TYIPEEK) 41.) ; |)|
(PROG2 (AND FL (PRINC '|() /
|) (TYO 12.))
(GO XIT)))
(SETQ N (1+ N)))
((= CHAR 41.) (SETQ N (1- N))) ; |)|
((AND (OR (= CHAR 78.) (= CHAR 110.)) (ZEROP N)) ; |N|, |n|
(AND FL (TYO CHAR))
(COND ((OR (= (SETQ CHAR (ZTYI)) 73.) (= CHAR 105.)) ; |I|, |i|
(AND FL (TYO CHAR))
(COND ((OR (= (SETQ CHAR (ZTYI)) 76.) ; |L|, |l|
(= CHAR 108.))
(AND FL (TYO CHAR))
(COND ((= (SETQ CHAR (ZTYI)) 32.)
(AND FL (PRINC '| /
|) (TYO 12.))
(GO XIT)))))))))
(AND FL (TYO CHAR))
(GO A)
XIT (LINEL UWRITE LINEL) ))
(DEFUN ZTYI ()
((LAMBDA (CHAR)
(AND (OR (= CHAR -1)
(AND ITSP
(= CHAR 3)
(OR (NOT (FILEP INFILE))
(AND (MEMQ 'FILEPOS (CDR (STATUS FILEM INFILE)))
(> (FILEPOS INFILE) (- (LENGTHF INFILE) 6))) )))
(SETQ TOPFN (CADR DATA)) ;set up name of losing LAP function
(DBARF '? |End-Of-File in middle of LAP code - check for misbalanced parens|))
CHAR)
(TYI -1)))
(COMMENT FUNCTIONS TO RUN DECLARATIONS)
;;; Switch Declarations functions
(DEFUN ASSEMBLE (X) (SETQ ASSEMBLE X)) ;;; A switch
(DEFUN CLOSED (X) (SETQ CLOSED X)) ;;; C switch
(DEFUN DISOWNED (X) (SETQ DISOWNED X)) ;;; D switch
(DEFUN EXPR-HASH (X) (SETQ EXPR-HASH X)) ;;; E switch
(DEFUN FASL (X) (SETQ FASL X)) ;;; F switch
(DEFUN FIXSW (X) (SETQ FIXSW X)) ;;; + switch
(DEFUN FLOSW (X) (SETQ FLOSW X)) ;;; $ switch
(DEFUN GAG-ERRBREAKS (X) (SETQ GAG-ERRBREAKS X)) ;;; G switch
(DEFUN MACROS (X) (SETQ MACROS X)) ;;; M switch
(DEFUN MAPEX (X) (SETQ MAPEX X)) ;;; X switch
(DEFUN MUZZLED (X) (SETQ MUZZLED X)) ;;; W switch
(DEFUN NOLAP (X) (SETQ NOLAP X)) ;;; K switch
(DEFUN ARRAYOPEN (X) (SETQ ARRAYOPEN X)) ;;; O switch
(DEFUN SPECIALS (X) (SETQ SPECIALS X)) ;;; S switch
(DEFUN SYMBOLS (X) (SETQ SYMBOLS X)) ;;; Z switch
(DEFUN UNFASLCOMMENTS (X) (SETQ UNFASLCOMMENTS X)) ;;; U switch
;;; Standard Declarations defined as FEXPRs
(DEFUN *EXPR FEXPR (X) (*DECLARE X '*EXPR))
(DEFUN *FEXPR FEXPR (X) (*DECLARE X '*FEXPR))
(DEFUN *LEXPR FEXPR (X) (*DECLARE X '*LEXPR))
(DEFUN /@DEFINE FEXPR (X) X 'T)
;;; HOW TO DISOWN FROM A ↑H BREAK
(DEFUN DISOWN FEXPR (X) (SETQ DISOWNED 'T) (GIVUPTTY) (THROW X BREAK))
(DEFUN EOC-EVAL FEXPR (X) (SETQ EOC-EVAL (APPEND EOC-EVAL X () )))
(DEFUN EVAL-WHEN FEXPR (L)
((LAMBDA (LOADP EVALP)
(AND (COND ((MEMQ COMPILER-STATE '(MAKLAP COMPILE))
(SETQ LOADP (MEMQ 'LOAD (CAR L))
EVALP (MEMQ 'COMPILE (CAR L)))
(OR EVALP LOADP))
;This allows for COMPILER-STATE to be () and TOPLEVEL
((SETQ EVALP (MEMQ 'EVAL (CAR L)))))
((LAMBDA (OBARRAY READTABLE)
(AND (NOT (MEMQ COMPILER-STATE '(MAKLAP COMPILE)))
(SETQ OBARRAY SOBARRAY READTABLE SREADTABLE))
(AND LOADP (MAPC 'COUTPUT (CDR L)))
(AND EVALP (MAPC 'EVAL (CDR L)))
'T)
COBARRAY CREADTABLE)))
() ()))
(DEFUN FIXNUM FEXPR (X) (NUMPROP X 'FIXNUM))
(DEFUN FLONUM FEXPR (X) (NUMPROP X 'FLONUM))
(DEFUN GENPREFIX FEXPR (X) (SETQ GENPREFIX (EXPLODEC (CAR X))))
(DEFUN NOTYPE FEXPR (DECLS) (NUMPROP DECLS () ))
(DEFUN OWN-SYMBOL FEXPR (L)
(COND ((NOT (MEMQ COMPILER-STATE '(MAKLAP DECLARE)))
(PDERR (CONS 'OWN-SYMBOL L)
|OWN declarations can only be made under MAKLAP|))
(((LAMBDA (OBARRAY)
(MAPCAN '(LAMBDA (X)
(COND ((NOT (SYMBOLP X)) () )
('T (REMOB X)
(PUTPROP (INTERN (COPYSYMBOL X () ))
'T
'OWN-SYMBOL)
(LIST X))))
L))
COBARRAY))))
(DEFUN RECOMPL FEXPR (X) (SETQ RECOMPL (APPEND X RECOMPL)))
(DEFUN SPECIAL FEXPR (X) (*DECLARE X 'SPECIAL))
(DEFUN UNSPECIAL FEXPR (L)
(COND ((EQ COMPILER-STATE 'COMPILE)
(PDERR (CONS 'UNSPECIAL L) |Cant locally unspecialize|))
('T (REMPROPL 'SPECIAL L))))
(DEFUN *DECLARE (L PROP)
(MAPC '(LAMBDA (X)
(COND ((AND (NOT (EQ PROP 'SPECIAL)) (SYSP X))
(COND ((OR (GET X 'CARCDR)
(AND (GET X 'FSUBR) (NOT (EQ X 'EDIT)) (NOT (EQ PROP '*FEXPR)))
(AND (GET X 'ACS) ;First char is * or .
((LAMBDA (N) (OR (= N 52) (= N 56)))
(GETCHARN X 1)))
(MEMQ X '(LIST CONS XCONS RPLACA RPLACD SET EQ EQUAL NULL NOT
ZEROP PROG2 PROGN ASSQ MEMQ BOOLE PRINC PRIN1 PRINT
READ READCH TYI TYO PLIST PUTPROP REMPROP)))
(DBARF (CONS PROP L) |This declaration wont work|))
('T (LREMPROP X '(ACS ARITHP NUMBERP NOTNUMP))
(PUTPROP X 'T PROP))))
(T (AND (EQ PROP 'SPECIAL)
(EQ COMPILER-STATE 'COMPILE)
(ASSQ X RNL) (SETQ X (CDR (ASSQ X RNL))))
(PUTPROP X
(COND ((EQ PROP 'SPECIAL) (LIST 'SPECIAL X))
('T))
PROP)))
() )
L))
(DEFUN NUMPROP (DECLS TYP)
(PROG (TEMP PROP TOPFN)
(MAPC '(LAMBDA (DECL)
(COND ((ATOM DECL)
(AND (EQ COMPILER-STATE 'COMPILE)
(SETQ TEMP (ASSQ DECL RNL))
(SETQ DECL (CDR TEMP)))
(COND ((NULL TYP) (REMPROP DECL 'NUMVAR))
((AND (SETQ TEMP (GET DECL 'NUMVAR))
(NOT (EQUAL TEMP TYP)))
(WARN DECL |Variable being redeclared|))
('T (PUTPROP DECL TYP 'NUMVAR))))
('T (SETQ PROP (NMPSUBST (CDR DECL) TYP))
(AND (SETQ TEMP (GET (CAR DECL) 'NUMFUN))
(NOT (EQUAL PROP TEMP))
(WARN DECL |Function being redeclared|))
(PUTPROP (CAR DECL) PROP 'NUMFUN))))
DECLS)))
(DEFUN NMPSUBST (LIST TYP)
(AND (DO X LIST (CDR X) (NULL X)
(AND (NOT (MEMQ (CAR X) '(() FIXNUM FLONUM))) (RETURN 'T)))
(SETQ LIST
(MAPCAR '(LAMBDA (X)
(COND ((MEMQ X '(() FIXNUM FLONUM)) X)
((EQ X 'NOTYPE) () )
(((LAMBDA (TYP)
(COND ((MEMQ TYP '(FIXNUM FLONUM)) TYP)
('T (PDERR (LIST X '-IN- (LIST TYP LIST))
|Incorrect arg for number declaration|)
() )))
(TYPEP X)))))
LIST)))
(CONS (REVERSE LIST) (CONS (COND ((NOT (MEMQ TYP '(FIXNUM FLONUM))) () )
(TYP))
LIST)))
(DEFUN ARRAY* FEXPR (LIST) (MAPC 'AR*1 LIST))
(DEFUN AR*1 (X)
(PROG (TYPE NAME TEM PROP N Y)
(AND (OR (ATOM X)
(NOT (MEMQ (CAR X) '(FIXNUM FLONUM NOTYPE))))
(GO BF))
(SETQ TYPE (CAR X) Y (CDR X))
A (AND (NULL Y) (RETURN () ))
(COND ((NOT (ATOM (CAR Y)))
(SETQ PROP (CAR Y) NAME (CAR PROP) N (LENGTH (CDR PROP)))
(DO Z (CDR PROP) (CDR Z) (NULL Z)
(COND ((FIXP (CAR Z)))
((AND (QNP (CAR Z)) (FIXP (CADAR Z)))
(RPLACA Z (CADAR Z)))
('T (RPLACA Z () )))))
((NOT (NUMBERP (CADR Y))) (GO BF))
('T (SETQ NAME (CAR Y) N (CADR Y) PROP (LIST NAME) Y (CDR Y))))
(AND (OR (LREMPROP NAME '(*EXPR *LEXPR *FEXPR))
(AND (REMPROP NAME 'NUMFUN) (NOT (GETL NAME '(*ARRAY)))))
(WARN NAME |Function being re-declared as an array|))
(COND ((AND (SETQ TEM (GET NAME '*ARRAY)) (NOT (EQUAL TEM PROP)))
#(WARN NAME |array re-declared|)
(REMPROP NAME 'NUMFUN)))
(PUTPROP NAME PROP '*ARRAY)
(PUTPROP NAME
(CONS () (CONS (COND ((NOT (EQ TYPE 'NOTYPE)) TYPE))
#(NCDR '(FIXNUM FIXNUM FIXNUM FIXNUM FIXNUM FIXNUM FIXNUM)
(- 7 N))))
'NUMFUN)
(SETQ Y (CDR Y))
(GO A)
BF (PDERR X |Bad array declaration|)))
(COMMENT FILL INITIAL ARRAYS)
(ARRAY AC-ADDRS T ##(+ (NUMVALAC) (NUMNACS) 1))
(ARRAY PDL-ADDRS T 3 ##(+ 1 (NPDL-ADDRS)))
(ARRAY STGET T ##(+ (NUMVALAC) (NUMNACS)))
(ARRAY BOLA T ##(+ (NACS) (NUMNACS) 1) 7)
(ARRAY CBA T 16.)
(ARRAY A1S1A T ##(NUMNACS) 4)
(ARRAY PVIA T 3 (1+ (MAX ##(MAX-NPUSH) ##(MAX-0PUSH) ##(MAX-0*0PUSH))))
(PROGN (DO CNT ##(+ (NUMVALAC) (NUMNACS)) (1- CNT) (< CNT 1) ;Sets AC-ADDRS
(STORE (AC-ADDRS CNT) CNT))
(DO CNT ##(NPDL-ADDRS) (1- CNT) (< CNT 1) ;Sets PDL-ADDRS
(STORE (PDL-ADDRS 0 CNT) (- CNT ##(NPDL-ADDRS)))
(STORE (PDL-ADDRS 1 CNT) (- (+ CNT ##(FXP0)) ##(NPDL-ADDRS)))
(STORE (PDL-ADDRS 2 CNT) (- (+ CNT ##(FLP0)) ##(NPDL-ADDRS))))
;;; (STGET n) is for accessing segment table into register n
(DO CNT ##(+ (NUMVALAC) (NUMNACS) -1) (1- CNT) (< CNT 1)
(STORE (STGET CNT) (SUBST CNT 'N '(0 ST N))))
(DO ((HLAC ##(+ (NACS) (NUMNACS)) (1- HLAC))
(ATPL (SUBST ##(NUMVALAC) 'AC '((TDZA N N)
(MOVEI N 'T)
(SKIPE 0 N)
(MOVNI AC N)
(MOVEI N '() )
(SKIPN 0 N) ))))
((< HLAC 1))
(DO ((CNT 1 (1+ CNT)) (ATPL1 ATPL (CDR ATPL1)))
((NULL ATPL1))
(STORE (BOLA HLAC CNT) (SUBST HLAC 'N (CAR ATPL1)))))
(FILLARRAY 'CBA '((SETZ) (AND) (ANDCA) (SETA) ;Sets CBA
(ANDCM) (SETM) (XOR) (IOR) (ANDCB)
(EQV) (SETCM) (ORCA) (SETCA)
(ORCM) (ORCB) (SETO)))
(DO CNT ##(- (NUMNACS) 1) (1- CNT) (< CNT 0) ;Sets A1S1A
(DO ((HLAC 0 (1+ HLAC)) (L '((ADDI 1)
(SUBI 1)
(FADRI 66304.) ;66304. = 201400[8]
(FSBRI 66304.))
(CDR L)))
((NULL L))
(STORE (A1S1A CNT HLAC) (LIST (CAAR L)
(+ CNT ##(NUMVALAC))
(CADAR L)))))
;;; Makes up array of JSPs to places that push the appropriate number
;;; of pdl-variable initialization values, onto the appropriate stack.
;;; (PVIA 0 n) ==> (JSP T (NPUSH -n)) pushes ()s onto REGPDL
;;; (PVIA 1 n) ==> (JSP T (0PUSH -n)) pushes 0s onto FXPDL
;;; (PVIA 2 n) ==> (JSP T (0*0PUSH -n)) pushes 0.0s onto FLPDL
(STORE (PVIA 0 0) ##(MAX-NPUSH))
(STORE (PVIA 1 0) ##(MAX-0PUSH))
(STORE (PVIA 2 0) ##(MAX-0*0PUSH))
(STORE (PVIA 0 1) '(PUSH P (% 0 0 '())))
(STORE (PVIA 1 1) '(PUSH FXP (% 0)))
(STORE (PVIA 2 1) '(PUSH FLP (% 0.0)))
(STORE (PVIA 0 2) 'NPUSH)
(STORE (PVIA 1 2) '0PUSH)
(STORE (PVIA 2 2) '0*0PUSH)
(DO CNT 0 (1+ CNT) (> CNT 2)
(DO HLAC (PVIA CNT 0) (1- HLAC) (< HLAC 3)
(STORE (PVIA CNT HLAC) (LIST 'JSP 'T (LIST (PVIA CNT 2) (- HLAC))))))
(COND (*PURE
(MAPC '(LAMBDA (GL)
(SETQ GL (GET GL 'ARRAY))
(DO CNT (1- (CADR (ARRAYDIMS GL))) (1- CNT) (< CNT 0)
(STORE (ARRAYCALL T GL CNT)
(PURCOPY (ARRAYCALL T GL CNT)))))
'(AC-ADDRS STGET CBA))
(MAPC '(LAMBDA (GL)
(SETQ GL (GET GL 'ARRAY))
(DO CNT (1- (CADR (ARRAYDIMS GL))) (1- CNT) (< CNT 0)
(DO HLAC (1- (CADDR (ARRAYDIMS GL)))
(1- HLAC)
(< HLAC 0)
(STORE (ARRAYCALL T GL CNT HLAC)
(PURCOPY (ARRAYCALL T GL CNT HLAC))))))
'(PDL-ADDRS BOLA A1S1A PVIA))))
)
(COMMENT PUT PROPERTIES ON VARIOUS SYMBOLS)
(PROGN (DEFPROP RPLACD (HRRM . HRRM) INST)
(DEFPROP RPLACA (HRLM . HRLM) INST)
(DEFPROP RPLACD (HLLZS . HLLZS) INSTN)
(DEFPROP RPLACA (HRRZS . HRRZS) INSTN)
(DEFPROP SETPLIST (HRRM . HRRM) INST)
(DEFPROP SETPLIST (HLLZS . HLLZS) INSTN)
(DEFPROP A (HLRZ . HLRZ) INST)
(DEFPROP D (HRRZ . HRRZ) INST)
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'IMMED))
'(MOVE CAMN CAME
ADD SUB IMUL IDIV CAMLE CAMG CAML CAMGE MOVN
AND ORCB SETCM XOR EQV IOR ANDCB ANDCA ANDCM ORCM ORCA)
'(MOVEI CAIN CAIE
ADDI SUBI IMULI IDIVI CAILE CAIG CAIL CAIGE MOVNI
ANDI ORCBI SETCMI XORI EQVI IORI ANDCBI ANDCAI ANDCMI ORCMI ORCAI))
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'JSP))
'(CONS XCONS NCONS %HUNK3 %HUNK4)
'(
(((JSP T %CONS) .
(JSP T %C2NS))
. ((JSP T %PDLC) .
(JSP T %C2NS)))
(((JSP T %XCONS) .
(JSP T %PDLXC))
. PUNT )
(((JSP T %NCONS)) .
((JSP T %PDLNC)))
((JSP T %HUNK3))
((JSP T %HUNK4))
))
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'COMMU) (PUTPROP INSTN INST 'COMMU))
'(CONS *GREAT *PLUS *TIMES EQUAL CAMG CAMGE JUMPGE JUMPL)
'(XCONS *LESS *PLUS *TIMES EQUAL CAML CAMLE JUMPLE JUMPG))
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'CONV) (PUTPROP INSTN INST 'CONV))
'(JUMP JUMPL JUMPE JUMPLE TRNN TLNN SOJE CAMG CAML
CAMN CAIG CAIL CAIE SKIPE SKIPG SKIPL)
'(JUMPA JUMPGE JUMPN JUMPG TRNE TLNE SOJN CAMLE CAMGE
CAME CAILE CAIGE CAIN SKIPN SKIPLE SKIPGE))
;A status option with no STATUS property means no evaluation of its
; entries. "(x . y)" means "x" is for sstatus and "y" for status;
; x and y are "A" to mean evaluate all but option name, and "B" to
; mean evaluate all but option name and next thing.
(MAPC '(LAMBDA (Z Y) (MAPC '(LAMBDA (X) (PUTPROP X Z 'STATUS)) Y))
'((A . A) (() . A) (A . () ) (B . B))
'((TTY TTYRE TTYTY TTYCO TTYSC TTYIN LINMO TERPR PDLMA INTER
GCMIN GCSIZ GCMAX)
(DIVOV FTVSI + TOPLE UUOLI ABBRE GCTIM GCWHO WHO1 WHO2 WHO3
EVALH BREAK MAR CLI FLUSH PUNT RANDO /← LOSEF)
(SYSTE SPCSI PURSI PDLSI PDLRO FILEM TTYSI OSPEE)
(MACRO SYNTA CHTRA)))
((LAMBDA (EXLDL GL) (FUNCALL EXLDL () () ))
'(LAMBDA (CARCDR LDLST)
((LAMBDA (EXIT EXITN)
(PUTPROP EXIT (CONS 'A (CONS CARCDR (CAR GL))) 'CARCDR)
(PUTPROP EXITN (CONS 'D (CONS CARCDR (CADR GL))) 'CARCDR)
(SETQ GL (CDDR GL))
(COND ((< (LENGTH LDLST) 3)
(FUNCALL EXLDL EXIT (CONS 'A LDLST))
(FUNCALL EXLDL EXITN (CONS 'D LDLST)))))
(IMPLODE (APPEND '(C A) LDLST '(R)))
(IMPLODE (APPEND '(C D) LDLST '(R)))))
'(6. 14. 5. 13. 19. 24. 27. 33. 36. 30. 3. 11. 17. 22. 1. 9.
4. 12. 18. 23. 26. 32. 35. 29. 2. 10. 16. 21. 0. 8.)) ;BOY! ARE THESE NUMBERS RANDOM!
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'MINUS))
'(MOVEI ADDI SUBI)
'(MOVNI SUBI ADDI))
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'BOTH))
'(ADD SUB IMUL IDIV FADR FSBR FDVR FMPR)
'(ADDB SUBB IMULB IDIVB FADRB FSBRB FDVRB FMPRB))
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'FLOATI))
'(FADR FSBR FMPR FDVR MOVE)
'(FADRI FSBRI FMPRI FDVRI MOVSI))
(MAPC '(LAMBDA (X)
(COND ((GET (CAR X) 'AUTOLOAD)
(AND (CDDR X) (ARGS (CAR X) (CDDR X)))
(AND (CDR X) (PUTPROP (CAR X) (CDR X) 'FUNTYP-INFO)))))
'((ALLFILES SUBR () . 1)
(CGOL FSUBR) (CGOLREAD LSUBR) (CREATE-JOB LSUBR 3 . 5)
(DIRECTORY LSUBR 1 . 2) (FORMAT LSUBR)
(DUMPARRAYS SUBR () . 2) (GETMIDASOP SUBR () . 1)
(GRIND FSUBR) (GRIND0 FSUBR) (GRINDEF FSUBR)
(INDEX) (INF-EDIT)
(LAP FSUBR) (LAP-A-LIST SUBR () . 1)
(LEDIT FSUBR) (LOADARRAYS SUBR () . 1)
(MAPALLFILES SUBR () . 2) (MAPDIRECTORY LSUBR 2 . 3)
(SORT SUBR () . 2) (SORTCAR SUBR () . 2)
(SPRINTER SUBR () . 1) (TRACE FSUBR)
))
(AND (STATUS FEATURE SAIL)
(MAPC '(LAMBDA (X)
(COND ((GET (CAR X) 'AUTOLOAD)
(AND (CDDR X) (ARGS (CAR X) (CDDR X)))
(AND (CDR X) (PUTPROP (CAR X) (CDR X) 'FUNTYP-INFO)))))
'((EREAD FSUBR) (EOPEN LSUBR 0 . 4) (UGREAT1 SUBR () . 1)
(EDIT FSUBR) (CODE FSUBR) (MAIL FSUBR))))
(DEFPROP %CATCHALL (FSUBR) FUNTYP-INFO)
(DEFPROP %PASS-THRU (FSUBR) FUNTYP-INFO)
(MAPC '(LAMBDA (X) (PUTPROP X 'NOTNUMP 'NOTNUMP)) ;Has no side-effects
'(
%HUNK3 %HUNK4 *APPEND ALPHALESSP
APPEND ARRAYDIMS ASSOC ASSQ ATOM BAKLIST
BIGP BOUNDP CONS COPYSYMBOL ERRFRAME
EVALFRAME EXPLODE EXPLODEC EXPLODEN
FILEP FIXP FLOATP GETCHAR GETL HUNK
HUNKP LAST LISTARRAY LISTIFY MAKNAM
MEMBER MEMQ NCONS NTHCDR NULL NUMBERP
PLIST PNGET REVERSE SAMEPNAMEP SIGNP
SUBLIS SUBST SYMBOLP SYSP TYPEP XCONS
))
(MAPC '(LAMBDA (X) (PUTPROP X 'EFFS 'NOTNUMP)) ;Has side-effects
'(
*ARRAY *DELETE *DELQ *NCONC *READCH *REARRAY
ALARMCLOCK ASCII CURSORPOS DELETE DELQ DUMPARRAYS
FILLARRAY GENSYM IMPLODE INTERN LOADARRAYS NCONC NRECONC
NREVERSE READCH REMOB REMPROP SASSOC SASSOC SASSQ SETPLIST
SETSYNTAX SORT SORTCAR SUSPEND TERPRI VALRET
))
(MAPC '(LAMBDA (X) (PUTPROP X 'T 'NOTNUMP)) ;Has side-effects, and returns T
'(TYO /+TYO *TYO DEPOSIT PRIN1 PRINC PRINT *PRIN1 *PRINC *PRINT))
;;; In general, function-names with ACS properties have no side-effects, except
;;; for those explicity mentioned under the NOTNUMP property above. Thus
;;; (NOT (GET x 'ACS)) is a general test for potentially-random side-effects.
(MAPC '(LAMBDA (DATA)
(MAPC '(LAMBDA (X) (AND (SYSP X) (PUTPROP X (CADAR DATA) (CAAR DATA))))
(CDR DATA)))
'(
((ACS 1) IN OUT CLOSE LINEL PAGEL CHARPOS LINENUM PAGENUM
CLEAR-INPUT CLEAR-OUTPUT FORCE-OUTPUT NAMELIST
TRUENAME PROBEF DELETEF DEFAULTF FASLP)
((ACS 2) MERGEF)
((ACS 3) NAMESTRING SHORTNAMESTRING)
((ACS 4) RUBOUT RENAMEF ENDPAGEFN EOFFN FILEP DELETEF FILEPOS
LENGTHF CNAMEF)
((ACS 5) OPEN)
;Missing are INCLUDE and LOAD, because they may cause
; totally unforseen side-effects
((ACS 1) LENGTH ADD1 SUB1 MINUS ABS FLOAT FIX
SIN COS SQRT LOG EXP ZEROP PLUSP MINUSP ODDP
1+ 1- 1+/$ 1-/$)
((ACS 1) LAST SLEEP RANDOM NOINTERRUPT EXAMINE
ARG MUNKAM ERRFRAME)
((ACS 2) PLUS TIMES EXPT DIFFERENCE QUOTIENT MAX MIN
GREATERP LESSP ATAN
*PLUS *TIMES *GREAT *QUO *DIF *LESS /\/\ /↑ /↑$
HAULONG HAIPART GCD BOOLE REMAINDER)
((ACS 2) GET REMPROP MEMQ RECLAIM EQUAL DEPOSIT
CONS NCONS XCONS SUBLIS NCONC *NCONC *DELQ
DELQ ASSQ ALARMCLOCK SETARG SETPLIST MAKNUM
SAMEPNAMEP ALPHALESSP GETCHARN MAKNAM LISTIFY
NTH NTHCDR)
((ACS 3) GENSYM FLATSIZE FLATC PNGET EVALFRAME PURIFY
LISTARRAY FILLARRAY DUMPARRAYS ARRAYDIMS
PRINT PRIN1 PRINC *PRINT *PRIN1 *PRINC
SYSP COPYSYMBOL SXHASH
REVERSE NREVERSE NRECONC GETL PUTPROP ARGS)
((ACS 4) ASSOC SASSOC SASSQ CRUNIT)
((ACS 4) %HUNK3 %HUNK4)
((ACS 5) SUBST *DELETE DELETE MEMBER *APPEND APPEND
*ARRAY *REARRAY LOADARRAYS
BAKTRACE BAKLIST ERRPRINT
ALLOC *FUNCTION SUSPEND SETSYNTAX
EXPLODEC EXPLODE EXPLODEN
PNPUT INTERN IMPLODE REMOB ASCII READCH *READCH
*TERPRI TERPRI *TYO TYO /+TYO *TYI TYI TYIPEEK
CURSORPOS
GETMIDASOP GETDDTSYM PUTDDTSYM
UREAD UWRITE UKILL UFILE UPROBE UCLOSE UAPPEND
)))
;EVAL, *EVAL, READ, *READ and MAP series aren't here, since
; they permint random evaluations [hence random side effects]
;PAGEBPORG isn't here since it setqs BPORG, and may cause a GC.
(MAPC '(LAMBDA (INST) (PUTPROP INST 'T 'P1BOOL1ABLE))
'(AND OR NULL NOT EQ = > < COND MEMQ SIGNP))
(MAPC '(LAMBDA (INST) (PUTPROP INST 'NUMBERP 'P1BOOL1ABLE))
'(EQUAL GREATERP LESSP ODDP *GREAT *LESS ZEROP PLUSP MINUSP))
(MAPC '(LAMBDA (INST INSTN)
(PUTPROP INST
(CONS (CONS 'TLNN INSTN) (CONS 'TLNE INSTN))
'P1BOOL1ABLE))
'(ATOM NUMBERP FIXP FLOATP BIGP HUNKP SYMBOLP)
;(175700 161400 121000 40400 20000 20 10000)
'(64448. 58112. 41472. 16640. 8192. 16. 4096.))
(MAPC '(LAMBDA (INST) (PUTPROP INST 'T 'CONTAGIOUS))
'(PLUS TIMES DIFFERENCE QUOTIENT *PLUS *TIMES *DIF *QUO))
(MAPC '(LAMBDA (INST) (PUTPROP INST 'T 'NUMBERP))
'(PLUS TIMES DIFFERENCE QUOTIENT *PLUS *TIMES *DIF *QUO
ABS MINUS FIX FLOAT IFIX ADD1 SUB1 REMAINDER HAULONG))
(MAPC '(LAMBDA (INST) (PUTPROP INST 'NOTYPE 'NUMBERP))
'(GREATERP LESSP *GREAT *LESS EQ EQUAL ODDP ZEROP PLUSP MINUSP))
(MAPC '(LAMBDA (X) (PUTPROP (CAR X) (CDR X) 'ARITHP))
'( (/+ PLUS FIXNUM) (+$ PLUS FLONUM)
(/- DIFFERENCE FIXNUM) (-$ DIFFERENCE FLONUM)
(/* TIMES FIXNUM) (*$ TIMES FLONUM)
(/1+ ADD1 FIXNUM) (1+$ ADD1 FLONUM)
(/1- SUB1 FIXNUM) (1-$ SUB1 FLONUM)
(// QUOTIENT FIXNUM) (//$ QUOTIENT FLONUM)
(/> GREATERP () ) (/< LESSP () )
(/\ REMAINDER FIXNUM) (/= EQUAL () )))
)
(COMMENT FINAL CLEANUP)
(GCTWA)
(AND *PURE (SETQ PUTPROP GOBRKL))
(SETQ NORET () )
(DECLARE (EVAL (READ)) (READ))
(SETSYNTAX '/# 'MACRO () ) ;Flushed after compilation
(PROG2 (SETQ CAR 'SYMBOL) (INITIALIZE MACRO)) ;For running interpretively only
'COMPILER/ LOADED
ββββ